1 module Network.DNS.Message
32 import Control.Exception
35 import Data.Binary.BitPut as BP
36 import Data.Binary.Get as G
37 import Data.Binary.Put as P
38 import Data.Binary.Strict.BitGet as BG
39 import qualified Data.ByteString as BS
40 import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
41 import qualified Data.ByteString.Lazy as LBS
43 import qualified Data.IntMap as IM
44 import Data.IntMap (IntMap)
49 replicateM' :: Monad m => Int -> (a -> m (b, a)) -> a -> m ([b], a)
50 replicateM' = worker []
52 worker :: Monad m => [b] -> Int -> (a -> m (b, a)) -> a -> m ([b], a)
53 worker soFar 0 _ a = return (reverse soFar, a)
54 worker soFar n f a = do (b, a') <- f a
55 worker (b : soFar) (n - 1) f a'
61 , msgQuestions :: ![Question]
62 , msgAnswers :: ![SomeRR]
63 , msgAuthorities :: ![SomeRR]
64 , msgAdditionals :: ![SomeRR]
70 hdMessageID :: !MessageID
71 , hdMessageType :: !MessageType
73 , hdIsAuthoritativeAnswer :: !Bool
74 , hdIsTruncated :: !Bool
75 , hdIsRecursionDesired :: !Bool
76 , hdIsRecursionAvailable :: !Bool
77 , hdResponseCode :: !ResponseCode
79 -- These fields are supressed in this data structure:
87 type MessageID = Word16
113 , qClass :: !RecordClass
119 putQ :: Question -> Put
121 = do putDomainName $ qName q
125 getQ :: DecompTable -> Get (Question, DecompTable)
127 = do (nm, dt') <- getDomainName dt
137 newtype DomainName = DN [DomainLabel] deriving (Eq, Show, Typeable)
138 type DomainLabel = BS.ByteString
140 nameToLabels :: DomainName -> [DomainLabel]
141 nameToLabels (DN ls) = ls
143 labelsToName :: [DomainLabel] -> DomainName
146 rootName :: DomainName
147 rootName = DN [BS.empty]
149 consLabel :: DomainLabel -> DomainName -> DomainName
150 consLabel x (DN ys) = DN (x:ys)
152 mkDomainName :: String -> DomainName
153 mkDomainName = labelsToName . mkLabels [] . notEmpty
155 notEmpty :: String -> String
156 notEmpty xs = assert (not $ null xs) xs
158 mkLabels :: [DomainLabel] -> String -> [DomainLabel]
159 mkLabels soFar [] = reverse (C8.empty : soFar)
160 mkLabels soFar xs = case break (== '.') xs of
162 -> mkLabels (C8.pack l : soFar) rest
163 _ -> error ("Illegal domain name: " ++ xs)
170 | AnyClass -- Only for queries
174 data RecordType rt dt => ResourceRecord rt dt
176 rrName :: !DomainName
178 , rrClass :: !RecordClass
182 deriving (Show, Eq, Typeable)
185 putRR :: forall rt dt. RecordType rt dt => ResourceRecord rt dt -> Put
186 putRR rr = do putDomainName $ rrName rr
187 putRecordType $ rrType rr
189 putWord32be $ rrTTL rr
192 putRecordData (undefined :: rt) (rrData rr)
193 putWord16be $ fromIntegral $ LBS.length dat
194 putLazyByteString dat
197 getRR :: forall rt dt. RecordType rt dt => DecompTable -> rt -> Get (ResourceRecord rt dt, DecompTable)
199 = do (nm, dt1) <- getDomainName dt
200 G.skip 2 -- record type
203 G.skip 2 -- data length
204 (dat, dt2) <- getRecordData (undefined :: rt) dt1
206 let rr = ResourceRecord {
216 data SomeRR = forall rt dt. RecordType rt dt => SomeRR (ResourceRecord rt dt)
218 instance Show SomeRR where
219 show (SomeRR rr) = show rr
221 instance Eq SomeRR where
222 (SomeRR a) == (SomeRR b) = Just a == cast b
225 putSomeRR :: SomeRR -> Put
226 putSomeRR (SomeRR rr) = putRR rr
228 getSomeRR :: DecompTable -> Get (SomeRR, DecompTable)
230 = do srt <- lookAhead $
231 do getDomainName dt -- skip
234 SomeRT rt -> getRR dt rt >>= \ (rr, dt') -> return (SomeRR rr, dt')
237 type DecompTable = IntMap DomainName
240 getDomainName :: DecompTable -> Get (DomainName, DecompTable)
241 getDomainName = worker
243 worker :: DecompTable -> Get (DomainName, DecompTable)
245 = do offset <- liftM fromIntegral bytesRead
246 hdr <- getLabelHeader
249 -> case IM.lookup n dt of
253 -> fail ("Illegal offset of label pointer: " ++ show (n, dt))
255 -> return (rootName, dt)
257 -> do label <- getByteString n
258 (rest, dt') <- worker dt
259 let name = consLabel label rest
260 dt'' = IM.insert offset name dt'
263 getLabelHeader :: Get LabelHeader
265 = do header <- lookAhead $ getByteString 1
270 n <- liftM fromIntegral (getAsWord8 6)
272 ( True, True) -> return $ Offset n
273 (False, False) -> return $ Length n
274 _ -> fail "Illegal label header"
277 -> do header' <- getByteString 2 -- Pointers have 2 octets.
279 = runBitGet header' $
281 n <- liftM fromIntegral (getAsWord16 14)
289 getCharString :: Get BS.ByteString
290 getCharString = do len <- G.getWord8
291 getByteString (fromIntegral len)
293 putCharString :: BS.ByteString -> Put
294 putCharString = putDomainLabel
300 putDomainName :: DomainName -> Put
301 putDomainName = mapM_ putDomainLabel . nameToLabels
303 putDomainLabel :: DomainLabel -> Put
305 = do putWord8 $ fromIntegral $ BS.length l
308 class (Show rt, Show dt, Eq rt, Eq dt, Typeable rt, Typeable dt) => RecordType rt dt | rt -> dt where
310 putRecordType :: rt -> Put
311 putRecordData :: rt -> dt -> Put
312 getRecordData :: rt -> DecompTable -> Get (dt, DecompTable)
314 putRecordType = putWord16be . fromIntegral . rtToInt
316 data SomeRT = forall rt dt. RecordType rt dt => SomeRT rt
318 instance Show SomeRT where
319 show (SomeRT rt) = show rt
321 instance Eq SomeRT where
322 (SomeRT a) == (SomeRT b) = Just a == cast b
324 putSomeRT :: SomeRT -> Put
325 putSomeRT (SomeRT rt) = putRecordType rt
327 getSomeRT :: Get SomeRT
328 getSomeRT = do n <- liftM fromIntegral G.getWord16be
329 case IM.lookup n defaultRTTable of
331 -> fail ("Unknown resource record type: " ++ show n)
335 data A = A deriving (Show, Eq, Typeable)
336 instance RecordType A HostAddress where
338 putRecordData _ = putWord32be
339 getRecordData _ = \ dt ->
340 do addr <- G.getWord32be
343 data NS = NS deriving (Show, Eq, Typeable)
344 instance RecordType NS DomainName where
346 putRecordData _ = putDomainName
347 getRecordData _ = getDomainName
349 data CNAME = CNAME deriving (Show, Eq, Typeable)
350 instance RecordType CNAME DomainName where
352 putRecordData _ = putDomainName
353 getRecordData _ = getDomainName
355 data HINFO = HINFO deriving (Show, Eq, Typeable)
356 instance RecordType HINFO (BS.ByteString, BS.ByteString) where
358 putRecordData _ (cpu, os) = do putCharString cpu
360 getRecordData _ dt = do cpu <- getCharString
362 return ((cpu, os), dt)
392 instance Binary Message where
393 put m = do put $ msgHeader m
394 putWord16be $ fromIntegral $ length $ msgQuestions m
395 putWord16be $ fromIntegral $ length $ msgAnswers m
396 putWord16be $ fromIntegral $ length $ msgAuthorities m
397 putWord16be $ fromIntegral $ length $ msgAdditionals m
398 mapM_ putQ $ msgQuestions m
399 mapM_ putSomeRR $ msgAnswers m
400 mapM_ putSomeRR $ msgAuthorities m
401 mapM_ putSomeRR $ msgAdditionals m
404 nQ <- liftM fromIntegral G.getWord16be
405 nAns <- liftM fromIntegral G.getWord16be
406 nAth <- liftM fromIntegral G.getWord16be
407 nAdd <- liftM fromIntegral G.getWord16be
408 (qs , dt1) <- replicateM' nQ getQ IM.empty
409 (anss, dt2) <- replicateM' nAns getSomeRR dt1
410 (aths, dt3) <- replicateM' nAth getSomeRR dt2
411 (adds, _ ) <- replicateM' nAdd getSomeRR dt3
416 , msgAuthorities = aths
417 , msgAdditionals = adds
420 instance Binary Header where
421 put h = do putWord16be $ hdMessageID h
422 putLazyByteString flags
425 do putNBits 1 $ fromEnum $ hdMessageType h
426 putNBits 4 $ fromEnum $ hdOpcode h
427 putBit $ hdIsAuthoritativeAnswer h
428 putBit $ hdIsTruncated h
429 putBit $ hdIsRecursionDesired h
430 putBit $ hdIsRecursionAvailable h
431 putNBits 3 (0 :: Int)
432 putNBits 4 $ fromEnum $ hdResponseCode h
434 get = do mID <- G.getWord16be
435 flags <- getByteString 2
438 do qr <- liftM (toEnum . fromIntegral) $ getAsWord8 1
439 op <- liftM (toEnum . fromIntegral) $ getAsWord8 4
445 rc <- liftM (toEnum . fromIntegral) $ getAsWord8 4
450 , hdIsAuthoritativeAnswer = aa
452 , hdIsRecursionDesired = rd
453 , hdIsRecursionAvailable = ra
454 , hdResponseCode = rc
458 instance Enum MessageType where
460 fromEnum Response = 1
466 instance Enum Opcode where
467 fromEnum StandardQuery = 0
468 fromEnum InverseQuery = 1
469 fromEnum ServerStatusRequest = 2
471 toEnum 0 = StandardQuery
472 toEnum 1 = InverseQuery
473 toEnum 2 = ServerStatusRequest
476 instance Enum ResponseCode where
478 fromEnum FormatError = 1
479 fromEnum ServerFailure = 2
480 fromEnum NameError = 3
481 fromEnum NotImplemented = 4
485 toEnum 1 = FormatError
486 toEnum 2 = ServerFailure
488 toEnum 4 = NotImplemented
493 instance Enum RecordType where
513 fromEnum AnyType = 255
538 instance Enum RecordClass where
543 fromEnum AnyClass = 255
549 toEnum 255 = AnyClass
552 instance Binary RecordClass where
553 get = liftM (toEnum . fromIntegral) G.getWord16be
554 put = putWord16be . fromIntegral . fromEnum
557 defaultRTTable :: IntMap SomeRT
558 defaultRTTable = IM.fromList $ map toPair $
561 , wrapRecordType CNAME
562 , wrapRecordType HINFO
565 toPair :: SomeRT -> (Int, SomeRT)
566 toPair srt@(SomeRT rt) = (rtToInt rt, srt)
569 wrapQueryType :: RecordType rt dt => rt -> SomeQT
570 wrapQueryType = SomeRT
572 wrapRecordType :: RecordType rt dt => rt -> SomeRT
573 wrapRecordType = SomeRT
575 wrapRecord :: RecordType rt dt => ResourceRecord rt dt -> SomeRR