1 module Network.DNS.Message
52 import Control.Exception
55 import Data.Binary.BitPut as BP
56 import Data.Binary.Get as G
57 import Data.Binary.Put as P'
58 import Data.Binary.Strict.BitGet as BG
59 import qualified Data.ByteString as BS
60 import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
61 import qualified Data.ByteString.Lazy as LBS
63 import qualified Data.IntMap as IM
64 import Data.IntMap (IntMap)
65 import qualified Data.IntSet as IS
66 import Data.IntSet (IntSet)
67 import qualified Data.Map as M
70 import Network.DNS.Packer as P
71 import Network.DNS.Unpacker as U
78 , msgQuestions :: ![SomeQ]
79 , msgAnswers :: ![SomeRR]
80 , msgAuthorities :: ![SomeRR]
81 , msgAdditionals :: ![SomeRR]
87 hdMessageID :: !MessageID
88 , hdMessageType :: !MessageType
90 , hdIsAuthoritativeAnswer :: !Bool
91 , hdIsTruncated :: !Bool
92 , hdIsRecursionDesired :: !Bool
93 , hdIsRecursionAvailable :: !Bool
94 , hdResponseCode :: !ResponseCode
96 -- These fields are supressed in this data structure:
104 type MessageID = Word16
114 | ServerStatusRequest
126 data QueryType qt => Question qt
130 , qClass :: !RecordClass
134 instance QueryType qt => Show (Question qt) where
135 show q = "Question { qName = " ++ show (qName q) ++
136 ", qType = " ++ show (qType q) ++
137 ", qClass = " ++ show (qClass q) ++ " }"
139 instance QueryType qt => Eq (Question qt) where
140 a == b = qName a == qName b &&
141 qType a == qType b &&
144 data SomeQ = forall qt. QueryType qt => SomeQ (Question qt)
146 instance Show SomeQ where
147 show (SomeQ q) = show q
149 instance Eq SomeQ where
150 (SomeQ a) == (SomeQ b) = Just a == cast b
152 data SomeQT = forall qt. QueryType qt => SomeQT qt
154 instance Show SomeQT where
155 show (SomeQT qt) = show qt
157 instance Eq SomeQT where
158 (SomeQT a) == (SomeQT b) = Just a == cast b
160 putSomeQ :: SomeQ -> Packer CompTable ()
162 = do putDomainName $ qName q
163 putQueryType $ qType q
166 getSomeQ :: Unpacker DecompTable SomeQ
168 = do nm <- getDomainName
172 SomeQT qt -> return $ SomeQ $
179 getSomeQT :: Unpacker s SomeQT
180 getSomeQT = do n <- liftM fromIntegral U.getWord16be
181 case IM.lookup n defaultQTTable of
185 -> fail ("Unknown query type: " ++ show n)
188 newtype DomainName = DN [DomainLabel] deriving (Eq, Show, Ord, Typeable)
189 type DomainLabel = BS.ByteString
191 rootName :: DomainName
192 rootName = DN [BS.empty]
194 isRootName :: DomainName -> Bool
195 isRootName (DN [_]) = True
198 consLabel :: DomainLabel -> DomainName -> DomainName
199 consLabel x (DN ys) = DN (x:ys)
201 unconsLabel :: DomainName -> (DomainLabel, DomainName)
202 unconsLabel (DN (x:xs)) = (x, DN xs)
203 unconsLabel x = error ("Illegal use of unconsLabel: " ++ show x)
205 mkDomainName :: String -> DomainName
206 mkDomainName = DN . mkLabels [] . notEmpty
208 notEmpty :: String -> String
209 notEmpty xs = assert (not $ null xs) xs
211 mkLabels :: [DomainLabel] -> String -> [DomainLabel]
212 mkLabels soFar [] = reverse (C8.empty : soFar)
213 mkLabels soFar xs = case break (== '.') xs of
215 -> mkLabels (C8.pack l : soFar) rest
216 _ -> error ("Illegal domain name: " ++ xs)
223 | AnyClass -- Only for queries
227 data RecordType rt dt => ResourceRecord rt dt
229 rrName :: !DomainName
231 , rrClass :: !RecordClass
235 deriving (Show, Eq, Typeable)
238 data SomeRR = forall rt dt. RecordType rt dt => SomeRR (ResourceRecord rt dt)
240 instance Show SomeRR where
241 show (SomeRR rr) = show rr
243 instance Eq SomeRR where
244 (SomeRR a) == (SomeRR b) = Just a == cast b
247 putSomeRR :: SomeRR -> Packer CompTable ()
248 putSomeRR (SomeRR rr) = putResourceRecord rr
250 getSomeRR :: Unpacker DecompTable SomeRR
251 getSomeRR = do srt <- U.lookAhead $
252 do getDomainName -- skip
256 -> getResourceRecord rt >>= return . SomeRR
258 type CompTable = Map DomainName Int
259 type DecompTable = IntMap DomainName
262 getDomainName :: Unpacker DecompTable DomainName
263 getDomainName = worker
265 worker :: Unpacker DecompTable DomainName
267 = do offset <- U.bytesRead
268 hdr <- getLabelHeader
271 -> do dt <- U.getState
272 case IM.lookup n dt of
276 -> fail ("Illegal offset of label pointer: " ++ show (n, dt))
280 -> do label <- U.getByteString n
282 let name = consLabel label rest
283 U.modifyState $ IM.insert offset name
286 getLabelHeader :: Unpacker s LabelHeader
288 = do header <- U.lookAhead $ U.getByteString 1
293 n <- liftM fromIntegral (getAsWord8 6)
295 ( True, True) -> return $ Offset n
296 (False, False) -> return $ Length n
297 _ -> fail "Illegal label header"
300 -> do header' <- U.getByteString 2 -- Pointers have 2 octets.
302 = runBitGet header' $
304 n <- liftM fromIntegral (getAsWord16 14)
312 getCharString :: Unpacker s BS.ByteString
313 getCharString = do len <- U.getWord8
314 U.getByteString (fromIntegral len)
316 putCharString :: BS.ByteString -> Packer s ()
317 putCharString xs = do P.putWord8 $ fromIntegral $ BS.length xs
324 putDomainName :: DomainName -> Packer CompTable ()
326 = do ct <- P.getState
327 case M.lookup name ct of
329 -> do let ptr = runBitPut $
333 P.putLazyByteString ptr
335 -> do offset <- bytesWrote
336 P.modifyState $ M.insert name offset
338 let (label, rest) = unconsLabel name
342 if isRootName rest then
347 class (Show qt, Eq qt, Typeable qt) => QueryType qt where
350 putQueryType :: qt -> Packer s ()
351 putQueryType = P.putWord16be . fromIntegral . qtToInt
353 instance RecordType rt dt => QueryType rt where
356 class (Show rt, Show dt, Eq rt, Eq dt, Typeable rt, Typeable dt) => RecordType rt dt | rt -> dt where
358 putRecordData :: rt -> dt -> Packer CompTable ()
359 getRecordData :: rt -> Unpacker DecompTable dt
361 putRecordType :: rt -> Packer s ()
362 putRecordType = P.putWord16be . fromIntegral . rtToInt
364 putRecordDataWithLength :: rt -> dt -> Packer CompTable ()
365 putRecordDataWithLength rt dt
366 = do -- First, write a dummy data length.
370 -- Second, write data.
373 -- Third, rewrite the dummy length to an actual value.
374 offset' <- bytesWrote
375 let len = offset' - offset - 2
376 if len <= 0xFFFF then
378 $ P.putWord16be $ fromIntegral len
380 fail ("putRecordData " ++ show rt ++ " wrote " ++ show len
381 ++ " bytes, which is way too long")
383 putResourceRecord :: ResourceRecord rt dt -> Packer CompTable ()
385 = do putDomainName $ rrName rr
386 putRecordType $ rrType rr
387 putBinary $ rrClass rr
388 P.putWord32be $ rrTTL rr
389 putRecordDataWithLength (rrType rr) (rrData rr)
391 getRecordDataWithLength :: rt -> Unpacker DecompTable dt
392 getRecordDataWithLength rt
393 = do len <- U.getWord16be
394 offset <- U.bytesRead
395 dat <- getRecordData rt
396 offset' <- U.bytesRead
398 let consumed = offset' - offset
399 when (consumed /= len)
400 $ fail ("getRecordData " ++ show rt ++ " consumed " ++ show consumed ++
401 " bytes but it had to consume " ++ show len ++ " bytes")
405 getResourceRecord :: rt -> Unpacker DecompTable (ResourceRecord rt dt)
407 = do name <- getDomainName
408 U.skip 2 -- record type
411 dat <- getRecordDataWithLength rt
412 return $ ResourceRecord {
420 data SomeRT = forall rt dt. RecordType rt dt => SomeRT rt
422 instance Show SomeRT where
423 show (SomeRT rt) = show rt
425 instance Eq SomeRT where
426 (SomeRT a) == (SomeRT b) = Just a == cast b
428 getSomeRT :: Unpacker s SomeRT
429 getSomeRT = do n <- liftM fromIntegral U.getWord16be
430 case IM.lookup n defaultRTTable of
432 -> fail ("Unknown resource record type: " ++ show n)
439 soaMasterNameServer :: !DomainName
440 , soaResponsibleMailbox :: !DomainName
441 , soaSerialNumber :: !Word32
442 , soaRefreshInterval :: !Word32
443 , soaRetryInterval :: !Word32
444 , soaExpirationLimit :: !Word32
445 , soaMinimumTTL :: !Word32
447 deriving (Show, Eq, Typeable)
451 wksAddress :: !HostAddress
452 , wksProtocol :: !ProtocolNumber
453 , wksServices :: !IntSet
455 deriving (Show, Eq, Typeable)
458 data A = A deriving (Show, Eq, Typeable)
459 instance RecordType A HostAddress where
461 putRecordData _ = P.putWord32be
462 getRecordData _ = U.getWord32be
464 data NS = NS deriving (Show, Eq, Typeable)
465 instance RecordType NS DomainName where
467 putRecordData _ = putDomainName
468 getRecordData _ = getDomainName
470 data MD = MD deriving (Show, Eq, Typeable)
471 instance RecordType MD DomainName where
473 putRecordData _ = putDomainName
474 getRecordData _ = getDomainName
476 data MF = MF deriving (Show, Eq, Typeable)
477 instance RecordType MF DomainName where
479 putRecordData _ = putDomainName
480 getRecordData _ = getDomainName
482 data CNAME = CNAME deriving (Show, Eq, Typeable)
483 instance RecordType CNAME DomainName where
485 putRecordData _ = putDomainName
486 getRecordData _ = getDomainName
488 data SOA = SOA deriving (Show, Eq, Typeable)
489 instance RecordType SOA SOAFields where
491 putRecordData _ = \ soa ->
492 do putDomainName $ soaMasterNameServer soa
493 putDomainName $ soaResponsibleMailbox soa
494 P.putWord32be $ soaSerialNumber soa
495 P.putWord32be $ soaRefreshInterval soa
496 P.putWord32be $ soaRetryInterval soa
497 P.putWord32be $ soaExpirationLimit soa
498 P.putWord32be $ soaMinimumTTL soa
499 getRecordData _ = do master <- getDomainName
500 mail <- getDomainName
501 serial <- U.getWord32be
502 refresh <- U.getWord32be
503 retry <- U.getWord32be
504 expire <- U.getWord32be
507 soaMasterNameServer = master
508 , soaResponsibleMailbox = mail
509 , soaSerialNumber = serial
510 , soaRefreshInterval = refresh
511 , soaRetryInterval = retry
512 , soaExpirationLimit = expire
513 , soaMinimumTTL = ttl
516 data MB = MB deriving (Show, Eq, Typeable)
517 instance RecordType MB DomainName where
519 putRecordData _ = putDomainName
520 getRecordData _ = getDomainName
522 data MG = MG deriving (Show, Eq, Typeable)
523 instance RecordType MG DomainName where
525 putRecordData _ = putDomainName
526 getRecordData _ = getDomainName
528 data MR = MR deriving (Show, Eq, Typeable)
529 instance RecordType MR DomainName where
531 putRecordData _ = putDomainName
532 getRecordData _ = getDomainName
534 data NULL = NULL deriving (Show, Eq, Typeable)
535 instance RecordType NULL BS.ByteString where
537 putRecordData _ _ = fail "putRecordData NULL can't be defined"
538 getRecordData _ = fail "getRecordData NULL can't be defined"
539 putRecordDataWithLength _ = \ dat ->
540 do P.putWord16be $ fromIntegral $ BS.length dat
542 getRecordDataWithLength _ = do len <- U.getWord16be
543 U.getByteString $ fromIntegral len
545 data WKS = WKS deriving (Show, Eq, Typeable)
546 instance RecordType WKS WKSFields where
548 putRecordData _ = \ wks ->
549 do P.putWord32be $ wksAddress wks
550 P.putWord8 $ fromIntegral $ wksProtocol wks
551 P.putLazyByteString $ toBitmap $ wksServices wks
553 toBitmap :: IntSet -> LBS.ByteString
555 = let maxPort = IS.findMax is
556 range = [0 .. maxPort]
557 isAvail p = p `IS.member` is
559 runBitPut $ mapM_ putBit $ map isAvail range
560 getRecordData _ = fail "getRecordData WKS can't be defined"
562 getRecordDataWithLength _
563 = do len <- U.getWord16be
564 addr <- U.getWord32be
565 proto <- liftM fromIntegral U.getWord8
566 bits <- U.getByteString $ fromIntegral $ len - 4 - 1
569 , wksProtocol = proto
570 , wksServices = fromBitmap bits
573 fromBitmap :: BS.ByteString -> IntSet
575 = let Right is = runBitGet bs $ worker 0 IS.empty
579 worker :: Int -> IntSet -> BitGet IntSet
581 = do remain <- BG.remaining
587 worker (pos + 1) (IS.insert pos is)
592 data PTR = PTR deriving (Show, Eq, Typeable)
593 instance RecordType PTR DomainName where
595 putRecordData _ = putDomainName
596 getRecordData _ = getDomainName
598 data HINFO = HINFO deriving (Show, Eq, Typeable)
599 instance RecordType HINFO (BS.ByteString, BS.ByteString) where
601 putRecordData _ = \ (cpu, os) ->
604 getRecordData _ = do cpu <- getCharString
608 data MINFO = MINFO deriving (Show, Eq, Typeable)
609 instance RecordType MINFO (DomainName, DomainName) where
611 putRecordData _ = \ (r, e) ->
614 getRecordData _ = do r <- getDomainName
618 data MX = MX deriving (Show, Eq, Typeable)
619 instance RecordType MX (Word16, DomainName) where
621 putRecordData _ = \ (pref, exch) ->
622 do P.putWord16be pref
624 getRecordData _ = do pref <- U.getWord16be
625 exch <- getDomainName
628 data TXT = TXT deriving (Show, Eq, Typeable)
629 instance RecordType TXT [BS.ByteString] where
631 putRecordData _ = mapM_ putCharString
632 getRecordData _ = fail "getRecordData TXT can't be defined"
634 getRecordDataWithLength _ = U.getWord16be >>= worker [] . fromIntegral
636 worker :: [BS.ByteString] -> Int -> Unpacker s [BS.ByteString]
637 worker soFar 0 = return (reverse soFar)
638 worker soFar n = do str <- getCharString
639 worker (str : soFar) (0 `max` n - 1 - BS.length str)
641 data AXFR = AXFR deriving (Show, Eq, Typeable)
642 instance QueryType AXFR where
645 data MAILB = MAILB deriving (Show, Eq, Typeable)
646 instance QueryType MAILB where
649 data MAILA = MAILA deriving (Show, Eq, Typeable)
650 instance QueryType MAILA where
653 data ANY = ANY deriving (Show, Eq, Typeable)
654 instance QueryType ANY where
658 instance Binary Message where
659 put m = P.liftToBinary M.empty $
660 do putBinary $ msgHeader m
661 P.putWord16be $ fromIntegral $ length $ msgQuestions m
662 P.putWord16be $ fromIntegral $ length $ msgAnswers m
663 P.putWord16be $ fromIntegral $ length $ msgAuthorities m
664 P.putWord16be $ fromIntegral $ length $ msgAdditionals m
665 mapM_ putSomeQ $ msgQuestions m
666 mapM_ putSomeRR $ msgAnswers m
667 mapM_ putSomeRR $ msgAuthorities m
668 mapM_ putSomeRR $ msgAdditionals m
670 get = U.liftToBinary IM.empty $
672 nQ <- liftM fromIntegral U.getWord16be
673 nAns <- liftM fromIntegral U.getWord16be
674 nAth <- liftM fromIntegral U.getWord16be
675 nAdd <- liftM fromIntegral U.getWord16be
676 qs <- replicateM nQ getSomeQ
677 anss <- replicateM nAns getSomeRR
678 aths <- replicateM nAth getSomeRR
679 adds <- replicateM nAdd getSomeRR
684 , msgAuthorities = aths
685 , msgAdditionals = adds
688 instance Binary Header where
689 put h = do P'.putWord16be $ hdMessageID h
690 P'.putLazyByteString flags
693 do putNBits 1 $ fromEnum $ hdMessageType h
694 putNBits 4 $ fromEnum $ hdOpcode h
695 putBit $ hdIsAuthoritativeAnswer h
696 putBit $ hdIsTruncated h
697 putBit $ hdIsRecursionDesired h
698 putBit $ hdIsRecursionAvailable h
699 putNBits 3 (0 :: Int)
700 putNBits 4 $ fromEnum $ hdResponseCode h
702 get = do mID <- G.getWord16be
703 flags <- G.getByteString 2
706 do qr <- liftM (toEnum . fromIntegral) $ getAsWord8 1
707 op <- liftM (toEnum . fromIntegral) $ getAsWord8 4
713 rc <- liftM (toEnum . fromIntegral) $ getAsWord8 4
718 , hdIsAuthoritativeAnswer = aa
720 , hdIsRecursionDesired = rd
721 , hdIsRecursionAvailable = ra
722 , hdResponseCode = rc
726 instance Enum MessageType where
728 fromEnum Response = 1
734 instance Enum Opcode where
735 fromEnum StandardQuery = 0
736 fromEnum InverseQuery = 1
737 fromEnum ServerStatusRequest = 2
739 toEnum 0 = StandardQuery
740 toEnum 1 = InverseQuery
741 toEnum 2 = ServerStatusRequest
744 instance Enum ResponseCode where
746 fromEnum FormatError = 1
747 fromEnum ServerFailure = 2
748 fromEnum NameError = 3
749 fromEnum NotImplemented = 4
753 toEnum 1 = FormatError
754 toEnum 2 = ServerFailure
756 toEnum 4 = NotImplemented
760 instance Enum RecordClass where
765 fromEnum AnyClass = 255
771 toEnum 255 = AnyClass
774 instance Binary RecordClass where
775 get = liftM (toEnum . fromIntegral) G.getWord16be
776 put = P'.putWord16be . fromIntegral . fromEnum
779 defaultRTTable :: IntMap SomeRT
780 defaultRTTable = IM.fromList $ map toPair $
785 , wrapRecordType CNAME
790 , wrapRecordType NULL
793 , wrapRecordType HINFO
794 , wrapRecordType MINFO
799 toPair :: SomeRT -> (Int, SomeRT)
800 toPair srt@(SomeRT rt) = (rtToInt rt, srt)
803 defaultQTTable :: IntMap SomeQT
804 defaultQTTable = mergeWithRTTable defaultRTTable $ IM.fromList $ map toPair $
806 , wrapQueryType MAILB
807 , wrapQueryType MAILA
811 toPair :: SomeQT -> (Int, SomeQT)
812 toPair sqt@(SomeQT qt) = (qtToInt qt, sqt)
814 mergeWithRTTable :: IntMap SomeRT -> IntMap SomeQT -> IntMap SomeQT
815 mergeWithRTTable rts qts
816 = IM.union (toQTTable rts) qts
818 toQTTable :: IntMap SomeRT -> IntMap SomeQT
819 toQTTable = IM.map toSomeQT
821 toSomeQT :: SomeRT -> SomeQT
822 toSomeQT (SomeRT rt) = SomeQT rt
825 wrapQueryType :: QueryType qt => qt -> SomeQT
826 wrapQueryType = SomeQT
828 wrapRecordType :: RecordType rt dt => rt -> SomeRT
829 wrapRecordType = SomeRT
831 wrapQuestion :: QueryType qt => Question qt -> SomeQ
834 wrapRecord :: RecordType rt dt => ResourceRecord rt dt -> SomeRR