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)
46 import Network.DNS.Unpacker as U
53 , msgQuestions :: ![Question]
54 , msgAnswers :: ![SomeRR]
55 , msgAuthorities :: ![SomeRR]
56 , msgAdditionals :: ![SomeRR]
62 hdMessageID :: !MessageID
63 , hdMessageType :: !MessageType
65 , hdIsAuthoritativeAnswer :: !Bool
66 , hdIsTruncated :: !Bool
67 , hdIsRecursionDesired :: !Bool
68 , hdIsRecursionAvailable :: !Bool
69 , hdResponseCode :: !ResponseCode
71 -- These fields are supressed in this data structure:
79 type MessageID = Word16
105 , qClass :: !RecordClass
111 putQ :: Question -> Put
113 = do putDomainName $ qName q
117 getQ :: Unpacker DecompTable Question
118 getQ = do nm <- getDomainName
128 newtype DomainName = DN [DomainLabel] deriving (Eq, Show, Typeable)
129 type DomainLabel = BS.ByteString
131 nameToLabels :: DomainName -> [DomainLabel]
132 nameToLabels (DN ls) = ls
134 labelsToName :: [DomainLabel] -> DomainName
137 rootName :: DomainName
138 rootName = DN [BS.empty]
140 consLabel :: DomainLabel -> DomainName -> DomainName
141 consLabel x (DN ys) = DN (x:ys)
143 mkDomainName :: String -> DomainName
144 mkDomainName = labelsToName . mkLabels [] . notEmpty
146 notEmpty :: String -> String
147 notEmpty xs = assert (not $ null xs) xs
149 mkLabels :: [DomainLabel] -> String -> [DomainLabel]
150 mkLabels soFar [] = reverse (C8.empty : soFar)
151 mkLabels soFar xs = case break (== '.') xs of
153 -> mkLabels (C8.pack l : soFar) rest
154 _ -> error ("Illegal domain name: " ++ xs)
161 | AnyClass -- Only for queries
165 data RecordType rt dt => ResourceRecord rt dt
167 rrName :: !DomainName
169 , rrClass :: !RecordClass
173 deriving (Show, Eq, Typeable)
176 putRR :: forall rt dt. RecordType rt dt => ResourceRecord rt dt -> Put
177 putRR rr = do putDomainName $ rrName rr
178 putRecordType $ rrType rr
180 putWord32be $ rrTTL rr
183 putRecordData (undefined :: rt) (rrData rr)
184 putWord16be $ fromIntegral $ LBS.length dat
185 putLazyByteString dat
188 data SomeRR = forall rt dt. RecordType rt dt => SomeRR (ResourceRecord rt dt)
190 instance Show SomeRR where
191 show (SomeRR rr) = show rr
193 instance Eq SomeRR where
194 (SomeRR a) == (SomeRR b) = Just a == cast b
197 putSomeRR :: SomeRR -> Put
198 putSomeRR (SomeRR rr) = putRR rr
200 getSomeRR :: Unpacker DecompTable SomeRR
201 getSomeRR = do srt <- U.lookAhead $
202 do getDomainName -- skip
206 -> getResourceRecord rt >>= return . SomeRR
208 type DecompTable = IntMap DomainName
211 getDomainName :: Unpacker DecompTable DomainName
212 getDomainName = worker
214 worker :: Unpacker DecompTable DomainName
216 = do offset <- U.bytesRead
217 hdr <- getLabelHeader
221 case IM.lookup n dt of
225 -> fail ("Illegal offset of label pointer: " ++ show (n, dt))
229 -> do label <- U.getByteString n
231 let name = consLabel label rest
232 modifyState $ IM.insert offset name
235 getLabelHeader :: Unpacker s LabelHeader
237 = do header <- U.lookAhead $ U.getByteString 1
242 n <- liftM fromIntegral (getAsWord8 6)
244 ( True, True) -> return $ Offset n
245 (False, False) -> return $ Length n
246 _ -> fail "Illegal label header"
249 -> do header' <- U.getByteString 2 -- Pointers have 2 octets.
251 = runBitGet header' $
253 n <- liftM fromIntegral (getAsWord16 14)
261 getCharString :: Unpacker s BS.ByteString
262 getCharString = do len <- U.getWord8
263 U.getByteString (fromIntegral len)
265 putCharString :: BS.ByteString -> Put
266 putCharString = putDomainLabel
272 putDomainName :: DomainName -> Put
273 putDomainName = mapM_ putDomainLabel . nameToLabels
275 putDomainLabel :: DomainLabel -> Put
277 = do putWord8 $ fromIntegral $ BS.length l
280 class (Show rt, Show dt, Eq rt, Eq dt, Typeable rt, Typeable dt) => RecordType rt dt | rt -> dt where
282 putRecordData :: rt -> dt -> Put
283 getRecordData :: rt -> Unpacker DecompTable dt
285 putRecordType :: rt -> Put
286 putRecordType = putWord16be . fromIntegral . rtToInt
288 getResourceRecord :: rt -> Unpacker DecompTable (ResourceRecord rt dt)
290 = do name <- getDomainName
291 U.skip 2 -- record type
294 U.skip 2 -- data length
295 dat <- getRecordData rt
296 return $ ResourceRecord {
304 data SomeRT = forall rt dt. RecordType rt dt => SomeRT rt
306 instance Show SomeRT where
307 show (SomeRT rt) = show rt
309 instance Eq SomeRT where
310 (SomeRT a) == (SomeRT b) = Just a == cast b
312 putSomeRT :: SomeRT -> Put
313 putSomeRT (SomeRT rt) = putRecordType rt
315 getSomeRT :: Unpacker s SomeRT
316 getSomeRT = do n <- liftM fromIntegral U.getWord16be
317 case IM.lookup n defaultRTTable of
319 -> fail ("Unknown resource record type: " ++ show n)
323 data A = A deriving (Show, Eq, Typeable)
324 instance RecordType A HostAddress where
326 putRecordData _ = putWord32be
327 getRecordData _ = U.getWord32be
329 data NS = NS deriving (Show, Eq, Typeable)
330 instance RecordType NS DomainName where
332 putRecordData _ = putDomainName
333 getRecordData _ = getDomainName
335 data CNAME = CNAME deriving (Show, Eq, Typeable)
336 instance RecordType CNAME DomainName where
338 putRecordData _ = putDomainName
339 getRecordData _ = getDomainName
341 data HINFO = HINFO deriving (Show, Eq, Typeable)
342 instance RecordType HINFO (BS.ByteString, BS.ByteString) where
344 putRecordData _ (cpu, os) = do putCharString cpu
346 getRecordData _ = do cpu <- getCharString
378 instance Binary Message where
379 put m = do put $ msgHeader m
380 putWord16be $ fromIntegral $ length $ msgQuestions m
381 putWord16be $ fromIntegral $ length $ msgAnswers m
382 putWord16be $ fromIntegral $ length $ msgAuthorities m
383 putWord16be $ fromIntegral $ length $ msgAdditionals m
384 mapM_ putQ $ msgQuestions m
385 mapM_ putSomeRR $ msgAnswers m
386 mapM_ putSomeRR $ msgAuthorities m
387 mapM_ putSomeRR $ msgAdditionals m
389 get = liftToBinary IM.empty $
391 nQ <- liftM fromIntegral U.getWord16be
392 nAns <- liftM fromIntegral U.getWord16be
393 nAth <- liftM fromIntegral U.getWord16be
394 nAdd <- liftM fromIntegral U.getWord16be
395 qs <- replicateM nQ getQ
396 anss <- replicateM nAns getSomeRR
397 aths <- replicateM nAth getSomeRR
398 adds <- replicateM nAdd getSomeRR
403 , msgAuthorities = aths
404 , msgAdditionals = adds
407 instance Binary Header where
408 put h = do putWord16be $ hdMessageID h
409 putLazyByteString flags
412 do putNBits 1 $ fromEnum $ hdMessageType h
413 putNBits 4 $ fromEnum $ hdOpcode h
414 putBit $ hdIsAuthoritativeAnswer h
415 putBit $ hdIsTruncated h
416 putBit $ hdIsRecursionDesired h
417 putBit $ hdIsRecursionAvailable h
418 putNBits 3 (0 :: Int)
419 putNBits 4 $ fromEnum $ hdResponseCode h
421 get = do mID <- G.getWord16be
422 flags <- G.getByteString 2
425 do qr <- liftM (toEnum . fromIntegral) $ getAsWord8 1
426 op <- liftM (toEnum . fromIntegral) $ getAsWord8 4
432 rc <- liftM (toEnum . fromIntegral) $ getAsWord8 4
437 , hdIsAuthoritativeAnswer = aa
439 , hdIsRecursionDesired = rd
440 , hdIsRecursionAvailable = ra
441 , hdResponseCode = rc
445 instance Enum MessageType where
447 fromEnum Response = 1
453 instance Enum Opcode where
454 fromEnum StandardQuery = 0
455 fromEnum InverseQuery = 1
456 fromEnum ServerStatusRequest = 2
458 toEnum 0 = StandardQuery
459 toEnum 1 = InverseQuery
460 toEnum 2 = ServerStatusRequest
463 instance Enum ResponseCode where
465 fromEnum FormatError = 1
466 fromEnum ServerFailure = 2
467 fromEnum NameError = 3
468 fromEnum NotImplemented = 4
472 toEnum 1 = FormatError
473 toEnum 2 = ServerFailure
475 toEnum 4 = NotImplemented
480 instance Enum RecordType where
500 fromEnum AnyType = 255
525 instance Enum RecordClass where
530 fromEnum AnyClass = 255
536 toEnum 255 = AnyClass
539 instance Binary RecordClass where
540 get = liftM (toEnum . fromIntegral) G.getWord16be
541 put = putWord16be . fromIntegral . fromEnum
544 defaultRTTable :: IntMap SomeRT
545 defaultRTTable = IM.fromList $ map toPair $
548 , wrapRecordType CNAME
549 , wrapRecordType HINFO
552 toPair :: SomeRT -> (Int, SomeRT)
553 toPair srt@(SomeRT rt) = (rtToInt rt, srt)
556 wrapQueryType :: RecordType rt dt => rt -> SomeQT
557 wrapQueryType = SomeRT
559 wrapRecordType :: RecordType rt dt => rt -> SomeRT
560 wrapRecordType = SomeRT
562 wrapRecord :: RecordType rt dt => ResourceRecord rt dt -> SomeRR