1 module Network.DNS.Message
66 import Control.Exception
69 import Data.Binary.BitPut as BP
70 import Data.Binary.Get as G
71 import Data.Binary.Put as P'
72 import Data.Binary.Strict.BitGet as BG
73 import qualified Data.ByteString as BS
74 import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
75 import qualified Data.ByteString.Lazy as LBS
78 import qualified Data.IntMap as IM
79 import Data.IntMap (IntMap)
80 import qualified Data.IntSet as IS
81 import Data.IntSet (IntSet)
83 import qualified Data.Map as M
86 import Network.DNS.Packer as P
87 import Network.DNS.Unpacker as U
94 , msgQuestions :: ![SomeQ]
95 , msgAnswers :: ![SomeRR]
96 , msgAuthorities :: ![SomeRR]
97 , msgAdditionals :: ![SomeRR]
103 hdMessageID :: !MessageID
104 , hdMessageType :: !MessageType
105 , hdOpcode :: !Opcode
106 , hdIsAuthoritativeAnswer :: !Bool
107 , hdIsTruncated :: !Bool
108 , hdIsRecursionDesired :: !Bool
109 , hdIsRecursionAvailable :: !Bool
110 , hdResponseCode :: !ResponseCode
112 -- These fields are supressed in this data structure:
120 type MessageID = Word16
130 | ServerStatusRequest
142 data (QueryType qt, QueryClass qc) => Question qt qc
150 instance (QueryType qt, QueryClass qc) => Show (Question qt qc) where
151 show q = "Question { qName = " ++ show (qName q) ++
152 ", qType = " ++ show (qType q) ++
153 ", qClass = " ++ show (qClass q) ++ " }"
155 instance (QueryType qt, QueryClass qc) => Eq (Question qt qc) where
156 a == b = qName a == qName b &&
157 qType a == qType b &&
160 data SomeQ = forall qt qc. (QueryType qt, QueryClass qc) => SomeQ (Question qt qc)
162 instance Show SomeQ where
163 show (SomeQ q) = show q
165 instance Eq SomeQ where
166 (SomeQ a) == (SomeQ b) = Just a == cast b
168 data SomeQT = forall qt. QueryType qt => SomeQT qt
170 instance Show SomeQT where
171 show (SomeQT qt) = show qt
173 instance Eq SomeQT where
174 (SomeQT a) == (SomeQT b) = Just a == cast b
176 data SomeQC = forall qc. QueryClass qc => SomeQC qc
178 instance Show SomeQC where
179 show (SomeQC qc) = show qc
181 instance Eq SomeQC where
182 (SomeQC a) == (SomeQC b) = Just a == cast b
184 putSomeQ :: SomeQ -> Packer CompTable ()
186 = do putDomainName $ qName q
187 putQueryType $ qType q
188 putQueryClass $ qClass q
190 getSomeQ :: Unpacker DecompTable SomeQ
192 = do nm <- getDomainName
196 (SomeQT qt, SomeQC qc)
197 -> return $ SomeQ $ Question {
203 getSomeQT :: Unpacker s SomeQT
204 getSomeQT = do n <- liftM fromIntegral U.getWord16be
205 case IM.lookup n defaultQTTable of
209 -> fail ("Unknown query type: " ++ show n)
211 getSomeQC :: Unpacker s SomeQC
212 getSomeQC = do n <- liftM fromIntegral U.getWord16be
213 case IM.lookup n defaultQCTable of
217 -> fail ("Unknown query class: " ++ show n)
220 newtype DomainName = DN [DomainLabel] deriving (Eq, Show, Ord, Typeable)
221 type DomainLabel = BS.ByteString
223 instance IsString DomainName where
224 fromString = mkDomainName
226 rootName :: DomainName
227 rootName = DN [BS.empty]
229 isRootName :: DomainName -> Bool
230 isRootName (DN [_]) = True
233 consLabel :: DomainLabel -> DomainName -> DomainName
234 consLabel x (DN ys) = DN (x:ys)
236 unconsLabel :: DomainName -> (DomainLabel, DomainName)
237 unconsLabel (DN (x:xs)) = (x, DN xs)
238 unconsLabel x = error ("Illegal use of unconsLabel: " ++ show x)
240 nameToLabels :: DomainName -> [DomainLabel]
241 nameToLabels (DN xs) = xs
243 isZoneOf :: DomainName -> DomainName -> Bool
244 isZoneOf (DN a) (DN b) = a `isSuffixOf` b
246 mkDomainName :: String -> DomainName
247 mkDomainName = DN . mkLabels [] . notEmpty
249 notEmpty :: String -> String
250 notEmpty xs = assert (not $ null xs) xs
252 mkLabels :: [DomainLabel] -> String -> [DomainLabel]
253 mkLabels soFar [] = reverse (C8.empty : soFar)
254 mkLabels soFar xs = case break (== '.') xs of
256 -> mkLabels (C8.pack l : soFar) rest
257 _ -> error ("Illegal domain name: " ++ xs)
260 class (Show rc, Eq rc, Typeable rc) => RecordClass rc where
263 putRecordClass :: rc -> Packer s ()
264 putRecordClass = P.putWord16be . fromIntegral . rcToInt
267 data (RecordType rt dt, RecordClass rc) => ResourceRecord rt rc dt
269 rrName :: !DomainName
275 deriving (Show, Eq, Typeable)
278 data SomeRR = forall rt rc dt. (RecordType rt dt, RecordClass rc) => SomeRR (ResourceRecord rt rc dt)
280 instance Show SomeRR where
281 show (SomeRR rr) = show rr
283 instance Eq SomeRR where
284 (SomeRR a) == (SomeRR b) = Just a == cast b
287 putSomeRR :: SomeRR -> Packer CompTable ()
288 putSomeRR (SomeRR rr) = putResourceRecord rr
290 getSomeRR :: Unpacker DecompTable SomeRR
291 getSomeRR = do (srt, src) <- U.lookAhead $
292 do getDomainName -- skip
297 (SomeRT rt, SomeRC rc)
298 -> getResourceRecord rt rc >>= return . SomeRR
300 type CompTable = Map DomainName Int
301 type DecompTable = IntMap DomainName
304 getDomainName :: Unpacker DecompTable DomainName
305 getDomainName = worker
307 worker :: Unpacker DecompTable DomainName
309 = do offset <- U.bytesRead
310 hdr <- getLabelHeader
313 -> do dt <- U.getState
314 case IM.lookup n dt of
318 -> fail ("Illegal offset of label pointer: " ++ show (n, dt))
322 -> do label <- U.getByteString n
324 let name = consLabel label rest
325 U.modifyState $ IM.insert offset name
328 getLabelHeader :: Unpacker s LabelHeader
330 = do header <- U.lookAhead $ U.getByteString 1
335 n <- liftM fromIntegral (getAsWord8 6)
337 ( True, True) -> return $ Offset n
338 (False, False) -> return $ Length n
339 _ -> fail "Illegal label header"
342 -> do header' <- U.getByteString 2 -- Pointers have 2 octets.
344 = runBitGet header' $
346 n <- liftM fromIntegral (getAsWord16 14)
354 getCharString :: Unpacker s BS.ByteString
355 getCharString = do len <- U.getWord8
356 U.getByteString (fromIntegral len)
358 putCharString :: BS.ByteString -> Packer s ()
359 putCharString xs = do P.putWord8 $ fromIntegral $ BS.length xs
366 putDomainName :: DomainName -> Packer CompTable ()
368 = do ct <- P.getState
369 case M.lookup name ct of
371 -> do let ptr = runBitPut $
375 P.putLazyByteString ptr
377 -> do offset <- bytesWrote
378 P.modifyState $ M.insert name offset
380 let (label, rest) = unconsLabel name
384 if isRootName rest then
389 class (Show qt, Eq qt, Typeable qt) => QueryType qt where
392 putQueryType :: qt -> Packer s ()
393 putQueryType = P.putWord16be . fromIntegral . qtToInt
395 instance RecordType rt dt => QueryType rt where
398 class (Show qc, Eq qc, Typeable qc) => QueryClass qc where
401 putQueryClass :: qc -> Packer s ()
402 putQueryClass = P.putWord16be . fromIntegral . qcToInt
404 instance RecordClass rc => QueryClass rc where
408 class (Show rt, Show dt, Eq rt, Eq dt, Typeable rt, Typeable dt) => RecordType rt dt | rt -> dt where
410 putRecordData :: rt -> dt -> Packer CompTable ()
411 getRecordData :: rt -> Unpacker DecompTable dt
413 putRecordType :: rt -> Packer s ()
414 putRecordType = P.putWord16be . fromIntegral . rtToInt
416 putRecordDataWithLength :: rt -> dt -> Packer CompTable ()
417 putRecordDataWithLength rt dt
418 = do -- First, write a dummy data length.
422 -- Second, write data.
425 -- Third, rewrite the dummy length to an actual value.
426 offset' <- bytesWrote
427 let len = offset' - offset - 2
428 if len <= 0xFFFF then
430 $ P.putWord16be $ fromIntegral len
432 fail ("putRecordData " ++ show rt ++ " wrote " ++ show len
433 ++ " bytes, which is way too long")
435 putResourceRecord :: RecordClass rc => ResourceRecord rt rc dt -> Packer CompTable ()
437 = do putDomainName $ rrName rr
438 putRecordType $ rrType rr
439 putRecordClass $ rrClass rr
440 P.putWord32be $ rrTTL rr
441 putRecordDataWithLength (rrType rr) (rrData rr)
443 getRecordDataWithLength :: rt -> Unpacker DecompTable dt
444 getRecordDataWithLength rt
445 = do len <- U.getWord16be
446 offset <- U.bytesRead
447 dat <- getRecordData rt
448 offset' <- U.bytesRead
450 let consumed = offset' - offset
451 when (consumed /= len)
452 $ fail ("getRecordData " ++ show rt ++ " consumed " ++ show consumed ++
453 " bytes but it had to consume " ++ show len ++ " bytes")
457 getResourceRecord :: RecordClass rc => rt -> rc -> Unpacker DecompTable (ResourceRecord rt rc dt)
458 getResourceRecord rt rc
459 = do name <- getDomainName
460 U.skip 2 -- record type
461 U.skip 2 -- record class
463 dat <- getRecordDataWithLength rt
464 return $ ResourceRecord {
473 data SomeRT = forall rt dt. RecordType rt dt => SomeRT rt
475 instance Show SomeRT where
476 show (SomeRT rt) = show rt
478 instance Eq SomeRT where
479 (SomeRT a) == (SomeRT b) = Just a == cast b
481 getSomeRT :: Unpacker s SomeRT
482 getSomeRT = do n <- liftM fromIntegral U.getWord16be
483 case IM.lookup n defaultRTTable of
485 -> fail ("Unknown resource record type: " ++ show n)
489 data SomeRC = forall rc. RecordClass rc => SomeRC rc
491 instance Show SomeRC where
492 show (SomeRC rc) = show rc
494 instance Eq SomeRC where
495 (SomeRC a) == (SomeRC b) = Just a == cast b
497 getSomeRC :: Unpacker s SomeRC
498 getSomeRC = do n <- liftM fromIntegral U.getWord16be
499 case IM.lookup n defaultRCTable of
501 -> fail ("Unknown resource record class: " ++ show n)
508 soaMasterNameServer :: !DomainName
509 , soaResponsibleMailbox :: !DomainName
510 , soaSerialNumber :: !Word32
511 , soaRefreshInterval :: !Word32
512 , soaRetryInterval :: !Word32
513 , soaExpirationLimit :: !Word32
514 , soaMinimumTTL :: !Word32
516 deriving (Show, Eq, Typeable)
520 wksAddress :: !HostAddress
521 , wksProtocol :: !ProtocolNumber
522 , wksServices :: !IntSet
524 deriving (Show, Eq, Typeable)
527 data A = A deriving (Show, Eq, Typeable)
528 instance RecordType A HostAddress where
530 putRecordData _ = P.putWord32be
531 getRecordData _ = U.getWord32be
533 data AAAA = AAAA deriving (Show, Eq, Typeable)
534 instance RecordType AAAA HostAddress6 where
536 putRecordData _ = \ (a, b, c, d) ->
541 getRecordData _ = do a <- U.getWord32be
547 data NS = NS deriving (Show, Eq, Typeable)
548 instance RecordType NS DomainName where
550 putRecordData _ = putDomainName
551 getRecordData _ = getDomainName
553 data MD = MD deriving (Show, Eq, Typeable)
554 instance RecordType MD DomainName where
556 putRecordData _ = putDomainName
557 getRecordData _ = getDomainName
559 data MF = MF deriving (Show, Eq, Typeable)
560 instance RecordType MF DomainName where
562 putRecordData _ = putDomainName
563 getRecordData _ = getDomainName
565 data CNAME = CNAME deriving (Show, Eq, Typeable)
566 instance RecordType CNAME DomainName where
568 putRecordData _ = putDomainName
569 getRecordData _ = getDomainName
571 data SOA = SOA deriving (Show, Eq, Typeable)
572 instance RecordType SOA SOAFields where
574 putRecordData _ = \ soa ->
575 do putDomainName $ soaMasterNameServer soa
576 putDomainName $ soaResponsibleMailbox soa
577 P.putWord32be $ soaSerialNumber soa
578 P.putWord32be $ soaRefreshInterval soa
579 P.putWord32be $ soaRetryInterval soa
580 P.putWord32be $ soaExpirationLimit soa
581 P.putWord32be $ soaMinimumTTL soa
582 getRecordData _ = do master <- getDomainName
583 mail <- getDomainName
584 serial <- U.getWord32be
585 refresh <- U.getWord32be
586 retry <- U.getWord32be
587 expire <- U.getWord32be
590 soaMasterNameServer = master
591 , soaResponsibleMailbox = mail
592 , soaSerialNumber = serial
593 , soaRefreshInterval = refresh
594 , soaRetryInterval = retry
595 , soaExpirationLimit = expire
596 , soaMinimumTTL = ttl
599 data MB = MB deriving (Show, Eq, Typeable)
600 instance RecordType MB DomainName where
602 putRecordData _ = putDomainName
603 getRecordData _ = getDomainName
605 data MG = MG deriving (Show, Eq, Typeable)
606 instance RecordType MG DomainName where
608 putRecordData _ = putDomainName
609 getRecordData _ = getDomainName
611 data MR = MR deriving (Show, Eq, Typeable)
612 instance RecordType MR DomainName where
614 putRecordData _ = putDomainName
615 getRecordData _ = getDomainName
617 data NULL = NULL deriving (Show, Eq, Typeable)
618 instance RecordType NULL BS.ByteString where
620 putRecordData _ _ = fail "putRecordData NULL can't be defined"
621 getRecordData _ = fail "getRecordData NULL can't be defined"
622 putRecordDataWithLength _ = \ dat ->
623 do P.putWord16be $ fromIntegral $ BS.length dat
625 getRecordDataWithLength _ = do len <- U.getWord16be
626 U.getByteString $ fromIntegral len
628 data WKS = WKS deriving (Show, Eq, Typeable)
629 instance RecordType WKS WKSFields where
631 putRecordData _ = \ wks ->
632 do P.putWord32be $ wksAddress wks
633 P.putWord8 $ fromIntegral $ wksProtocol wks
634 P.putLazyByteString $ toBitmap $ wksServices wks
636 toBitmap :: IntSet -> LBS.ByteString
638 = let maxPort = IS.findMax is
639 range = [0 .. maxPort]
640 isAvail p = p `IS.member` is
642 runBitPut $ mapM_ putBit $ map isAvail range
643 getRecordData _ = fail "getRecordData WKS can't be defined"
645 getRecordDataWithLength _
646 = do len <- U.getWord16be
647 addr <- U.getWord32be
648 proto <- liftM fromIntegral U.getWord8
649 bits <- U.getByteString $ fromIntegral $ len - 4 - 1
652 , wksProtocol = proto
653 , wksServices = fromBitmap bits
656 fromBitmap :: BS.ByteString -> IntSet
658 = let Right is = runBitGet bs $ worker 0 IS.empty
662 worker :: Int -> IntSet -> BitGet IntSet
664 = do remain <- BG.remaining
670 worker (pos + 1) (IS.insert pos is)
675 data PTR = PTR deriving (Show, Eq, Typeable)
676 instance RecordType PTR DomainName where
678 putRecordData _ = putDomainName
679 getRecordData _ = getDomainName
681 data HINFO = HINFO deriving (Show, Eq, Typeable)
682 instance RecordType HINFO (BS.ByteString, BS.ByteString) where
684 putRecordData _ = \ (cpu, os) ->
687 getRecordData _ = do cpu <- getCharString
691 data MINFO = MINFO deriving (Show, Eq, Typeable)
692 instance RecordType MINFO (DomainName, DomainName) where
694 putRecordData _ = \ (r, e) ->
697 getRecordData _ = do r <- getDomainName
701 data MX = MX deriving (Show, Eq, Typeable)
702 instance RecordType MX (Word16, DomainName) where
704 putRecordData _ = \ (pref, exch) ->
705 do P.putWord16be pref
707 getRecordData _ = do pref <- U.getWord16be
708 exch <- getDomainName
711 data TXT = TXT deriving (Show, Eq, Typeable)
712 instance RecordType TXT [BS.ByteString] where
714 putRecordData _ = mapM_ putCharString
715 getRecordData _ = fail "getRecordData TXT can't be defined"
717 getRecordDataWithLength _ = U.getWord16be >>= worker [] . fromIntegral
719 worker :: [BS.ByteString] -> Int -> Unpacker s [BS.ByteString]
720 worker soFar 0 = return (reverse soFar)
721 worker soFar n = do str <- getCharString
722 worker (str : soFar) (0 `max` n - 1 - BS.length str)
724 data AXFR = AXFR deriving (Show, Eq, Typeable)
725 instance QueryType AXFR where
728 data MAILB = MAILB deriving (Show, Eq, Typeable)
729 instance QueryType MAILB where
732 data MAILA = MAILA deriving (Show, Eq, Typeable)
733 instance QueryType MAILA where
736 data ANY = ANY deriving (Show, Eq, Typeable)
737 instance QueryType ANY where
739 instance QueryClass ANY where
742 data IN = IN deriving (Show, Eq, Typeable)
743 instance RecordClass IN where
746 data CS = CS deriving (Show, Eq, Typeable)
747 instance RecordClass CS where
750 data CH = CH deriving (Show, Eq, Typeable)
751 instance RecordClass CH where
754 data HS = HS deriving (Show, Eq, Typeable)
755 instance RecordClass HS where
759 instance Binary Message where
760 put m = P.liftToBinary M.empty $
761 do putBinary $ msgHeader m
762 P.putWord16be $ fromIntegral $ length $ msgQuestions m
763 P.putWord16be $ fromIntegral $ length $ msgAnswers m
764 P.putWord16be $ fromIntegral $ length $ msgAuthorities m
765 P.putWord16be $ fromIntegral $ length $ msgAdditionals m
766 mapM_ putSomeQ $ msgQuestions m
767 mapM_ putSomeRR $ msgAnswers m
768 mapM_ putSomeRR $ msgAuthorities m
769 mapM_ putSomeRR $ msgAdditionals m
771 get = U.liftToBinary IM.empty $
773 nQ <- liftM fromIntegral U.getWord16be
774 nAns <- liftM fromIntegral U.getWord16be
775 nAth <- liftM fromIntegral U.getWord16be
776 nAdd <- liftM fromIntegral U.getWord16be
777 qs <- replicateM nQ getSomeQ
778 anss <- replicateM nAns getSomeRR
779 aths <- replicateM nAth getSomeRR
780 adds <- replicateM nAdd getSomeRR
785 , msgAuthorities = aths
786 , msgAdditionals = adds
789 instance Binary Header where
790 put h = do P'.putWord16be $ hdMessageID h
791 P'.putLazyByteString flags
794 do putNBits 1 $ fromEnum $ hdMessageType h
795 putNBits 4 $ fromEnum $ hdOpcode h
796 putBit $ hdIsAuthoritativeAnswer h
797 putBit $ hdIsTruncated h
798 putBit $ hdIsRecursionDesired h
799 putBit $ hdIsRecursionAvailable h
800 putNBits 3 (0 :: Int)
801 putNBits 4 $ fromEnum $ hdResponseCode h
803 get = do mID <- G.getWord16be
804 flags <- G.getByteString 2
807 do qr <- liftM (toEnum . fromIntegral) $ getAsWord8 1
808 op <- liftM (toEnum . fromIntegral) $ getAsWord8 4
814 rc <- liftM (toEnum . fromIntegral) $ getAsWord8 4
819 , hdIsAuthoritativeAnswer = aa
821 , hdIsRecursionDesired = rd
822 , hdIsRecursionAvailable = ra
823 , hdResponseCode = rc
827 instance Enum MessageType where
829 fromEnum Response = 1
835 instance Enum Opcode where
836 fromEnum StandardQuery = 0
837 fromEnum InverseQuery = 1
838 fromEnum ServerStatusRequest = 2
840 toEnum 0 = StandardQuery
841 toEnum 1 = InverseQuery
842 toEnum 2 = ServerStatusRequest
845 instance Enum ResponseCode where
847 fromEnum FormatError = 1
848 fromEnum ServerFailure = 2
849 fromEnum NameError = 3
850 fromEnum NotImplemented = 4
854 toEnum 1 = FormatError
855 toEnum 2 = ServerFailure
857 toEnum 4 = NotImplemented
862 defaultRTTable :: IntMap SomeRT
863 defaultRTTable = IM.fromList $ map toPair $
883 toPair :: SomeRT -> (Int, SomeRT)
884 toPair srt@(SomeRT rt) = (rtToInt rt, srt)
886 defaultQTTable :: IntMap SomeQT
887 defaultQTTable = mergeWithRTTable defaultRTTable $ IM.fromList $ map toPair $
894 toPair :: SomeQT -> (Int, SomeQT)
895 toPair sqt@(SomeQT qt) = (qtToInt qt, sqt)
897 mergeWithRTTable :: IntMap SomeRT -> IntMap SomeQT -> IntMap SomeQT
898 mergeWithRTTable rts qts
899 = IM.union (toQTTable rts) qts
901 toQTTable :: IntMap SomeRT -> IntMap SomeQT
902 toQTTable = IM.map toSomeQT
904 toSomeQT :: SomeRT -> SomeQT
905 toSomeQT (SomeRT rt) = SomeQT rt
907 defaultRCTable :: IntMap SomeRC
908 defaultRCTable = IM.fromList $ map toPair $
915 toPair :: SomeRC -> (Int, SomeRC)
916 toPair src@(SomeRC rc) = (rcToInt rc, src)
918 defaultQCTable :: IntMap SomeQC
919 defaultQCTable = mergeWithRCTable defaultRCTable $ IM.fromList $ map toPair $
923 toPair :: SomeQC -> (Int, SomeQC)
924 toPair sqc@(SomeQC qc) = (qcToInt qc, sqc)
926 mergeWithRCTable :: IntMap SomeRC -> IntMap SomeQC -> IntMap SomeQC
927 mergeWithRCTable rcs qcs
928 = IM.union (toQCTable rcs) qcs
930 toQCTable :: IntMap SomeRC -> IntMap SomeQC
931 toQCTable = IM.map toSomeQC
933 toSomeQC :: SomeRC -> SomeQC
934 toSomeQC (SomeRC rc) = SomeQC rc
937 wrapQuestion :: (QueryType qt, QueryClass qc) => Question qt qc -> SomeQ
940 wrapRecord :: (RecordType rt dt, RecordClass rc) => ResourceRecord rt rc dt -> SomeRR