1 module Network.DNS.Message
61 import Control.Exception
64 import Data.Binary.BitPut as BP
65 import Data.Binary.Get as G
66 import Data.Binary.Put as P'
67 import Data.Binary.Strict.BitGet as BG
68 import qualified Data.ByteString as BS
69 import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
70 import qualified Data.ByteString.Lazy as LBS
72 import qualified Data.IntMap as IM
73 import Data.IntMap (IntMap)
74 import qualified Data.IntSet as IS
75 import Data.IntSet (IntSet)
77 import qualified Data.Map as M
80 import Network.DNS.Packer as P
81 import Network.DNS.Unpacker as U
88 , msgQuestions :: ![SomeQ]
89 , msgAnswers :: ![SomeRR]
90 , msgAuthorities :: ![SomeRR]
91 , msgAdditionals :: ![SomeRR]
97 hdMessageID :: !MessageID
98 , hdMessageType :: !MessageType
100 , hdIsAuthoritativeAnswer :: !Bool
101 , hdIsTruncated :: !Bool
102 , hdIsRecursionDesired :: !Bool
103 , hdIsRecursionAvailable :: !Bool
104 , hdResponseCode :: !ResponseCode
106 -- These fields are supressed in this data structure:
114 type MessageID = Word16
124 | ServerStatusRequest
136 data (QueryType qt, QueryClass qc) => Question qt qc
144 instance (QueryType qt, QueryClass qc) => Show (Question qt qc) where
145 show q = "Question { qName = " ++ show (qName q) ++
146 ", qType = " ++ show (qType q) ++
147 ", qClass = " ++ show (qClass q) ++ " }"
149 instance (QueryType qt, QueryClass qc) => Eq (Question qt qc) where
150 a == b = qName a == qName b &&
151 qType a == qType b &&
154 data SomeQ = forall qt qc. (QueryType qt, QueryClass qc) => SomeQ (Question qt qc)
156 instance Show SomeQ where
157 show (SomeQ q) = show q
159 instance Eq SomeQ where
160 (SomeQ a) == (SomeQ b) = Just a == cast b
162 data SomeQT = forall qt. QueryType qt => SomeQT qt
164 instance Show SomeQT where
165 show (SomeQT qt) = show qt
167 instance Eq SomeQT where
168 (SomeQT a) == (SomeQT b) = Just a == cast b
170 data SomeQC = forall qc. QueryClass qc => SomeQC qc
172 instance Show SomeQC where
173 show (SomeQC qc) = show qc
175 instance Eq SomeQC where
176 (SomeQC a) == (SomeQC b) = Just a == cast b
178 putSomeQ :: SomeQ -> Packer CompTable ()
180 = do putDomainName $ qName q
181 putQueryType $ qType q
182 putQueryClass $ qClass q
184 getSomeQ :: Unpacker DecompTable SomeQ
186 = do nm <- getDomainName
190 (SomeQT qt, SomeQC qc)
191 -> return $ SomeQ $ Question {
197 getSomeQT :: Unpacker s SomeQT
198 getSomeQT = do n <- liftM fromIntegral U.getWord16be
199 case IM.lookup n defaultQTTable of
203 -> fail ("Unknown query type: " ++ show n)
205 getSomeQC :: Unpacker s SomeQC
206 getSomeQC = do n <- liftM fromIntegral U.getWord16be
207 case IM.lookup n defaultQCTable of
211 -> fail ("Unknown query class: " ++ show n)
214 newtype DomainName = DN [DomainLabel] deriving (Eq, Show, Ord, Typeable)
215 type DomainLabel = BS.ByteString
217 rootName :: DomainName
218 rootName = DN [BS.empty]
220 isRootName :: DomainName -> Bool
221 isRootName (DN [_]) = True
224 consLabel :: DomainLabel -> DomainName -> DomainName
225 consLabel x (DN ys) = DN (x:ys)
227 unconsLabel :: DomainName -> (DomainLabel, DomainName)
228 unconsLabel (DN (x:xs)) = (x, DN xs)
229 unconsLabel x = error ("Illegal use of unconsLabel: " ++ show x)
231 isZoneOf :: DomainName -> DomainName -> Bool
232 isZoneOf (DN a) (DN b) = a `isSuffixOf` b
234 mkDomainName :: String -> DomainName
235 mkDomainName = DN . mkLabels [] . notEmpty
237 notEmpty :: String -> String
238 notEmpty xs = assert (not $ null xs) xs
240 mkLabels :: [DomainLabel] -> String -> [DomainLabel]
241 mkLabels soFar [] = reverse (C8.empty : soFar)
242 mkLabels soFar xs = case break (== '.') xs of
244 -> mkLabels (C8.pack l : soFar) rest
245 _ -> error ("Illegal domain name: " ++ xs)
247 mkDN :: String -> DomainName
251 class (Show rc, Eq rc, Typeable rc) => RecordClass rc where
254 putRecordClass :: rc -> Packer s ()
255 putRecordClass = P.putWord16be . fromIntegral . rcToInt
258 data (RecordType rt dt, RecordClass rc) => ResourceRecord rt rc dt
260 rrName :: !DomainName
266 deriving (Show, Eq, Typeable)
269 data SomeRR = forall rt rc dt. (RecordType rt dt, RecordClass rc) => SomeRR (ResourceRecord rt rc dt)
271 instance Show SomeRR where
272 show (SomeRR rr) = show rr
274 instance Eq SomeRR where
275 (SomeRR a) == (SomeRR b) = Just a == cast b
278 putSomeRR :: SomeRR -> Packer CompTable ()
279 putSomeRR (SomeRR rr) = putResourceRecord rr
281 getSomeRR :: Unpacker DecompTable SomeRR
282 getSomeRR = do (srt, src) <- U.lookAhead $
283 do getDomainName -- skip
288 (SomeRT rt, SomeRC rc)
289 -> getResourceRecord rt rc >>= return . SomeRR
291 type CompTable = Map DomainName Int
292 type DecompTable = IntMap DomainName
295 getDomainName :: Unpacker DecompTable DomainName
296 getDomainName = worker
298 worker :: Unpacker DecompTable DomainName
300 = do offset <- U.bytesRead
301 hdr <- getLabelHeader
304 -> do dt <- U.getState
305 case IM.lookup n dt of
309 -> fail ("Illegal offset of label pointer: " ++ show (n, dt))
313 -> do label <- U.getByteString n
315 let name = consLabel label rest
316 U.modifyState $ IM.insert offset name
319 getLabelHeader :: Unpacker s LabelHeader
321 = do header <- U.lookAhead $ U.getByteString 1
326 n <- liftM fromIntegral (getAsWord8 6)
328 ( True, True) -> return $ Offset n
329 (False, False) -> return $ Length n
330 _ -> fail "Illegal label header"
333 -> do header' <- U.getByteString 2 -- Pointers have 2 octets.
335 = runBitGet header' $
337 n <- liftM fromIntegral (getAsWord16 14)
345 getCharString :: Unpacker s BS.ByteString
346 getCharString = do len <- U.getWord8
347 U.getByteString (fromIntegral len)
349 putCharString :: BS.ByteString -> Packer s ()
350 putCharString xs = do P.putWord8 $ fromIntegral $ BS.length xs
357 putDomainName :: DomainName -> Packer CompTable ()
359 = do ct <- P.getState
360 case M.lookup name ct of
362 -> do let ptr = runBitPut $
366 P.putLazyByteString ptr
368 -> do offset <- bytesWrote
369 P.modifyState $ M.insert name offset
371 let (label, rest) = unconsLabel name
375 if isRootName rest then
380 class (Show qt, Eq qt, Typeable qt) => QueryType qt where
383 putQueryType :: qt -> Packer s ()
384 putQueryType = P.putWord16be . fromIntegral . qtToInt
386 instance RecordType rt dt => QueryType rt where
389 class (Show qc, Eq qc, Typeable qc) => QueryClass qc where
392 putQueryClass :: qc -> Packer s ()
393 putQueryClass = P.putWord16be . fromIntegral . qcToInt
395 instance RecordClass rc => QueryClass rc where
399 class (Show rt, Show dt, Eq rt, Eq dt, Typeable rt, Typeable dt) => RecordType rt dt | rt -> dt where
401 putRecordData :: rt -> dt -> Packer CompTable ()
402 getRecordData :: rt -> Unpacker DecompTable dt
404 putRecordType :: rt -> Packer s ()
405 putRecordType = P.putWord16be . fromIntegral . rtToInt
407 putRecordDataWithLength :: rt -> dt -> Packer CompTable ()
408 putRecordDataWithLength rt dt
409 = do -- First, write a dummy data length.
413 -- Second, write data.
416 -- Third, rewrite the dummy length to an actual value.
417 offset' <- bytesWrote
418 let len = offset' - offset - 2
419 if len <= 0xFFFF then
421 $ P.putWord16be $ fromIntegral len
423 fail ("putRecordData " ++ show rt ++ " wrote " ++ show len
424 ++ " bytes, which is way too long")
426 putResourceRecord :: RecordClass rc => ResourceRecord rt rc dt -> Packer CompTable ()
428 = do putDomainName $ rrName rr
429 putRecordType $ rrType rr
430 putRecordClass $ rrClass rr
431 P.putWord32be $ rrTTL rr
432 putRecordDataWithLength (rrType rr) (rrData rr)
434 getRecordDataWithLength :: rt -> Unpacker DecompTable dt
435 getRecordDataWithLength rt
436 = do len <- U.getWord16be
437 offset <- U.bytesRead
438 dat <- getRecordData rt
439 offset' <- U.bytesRead
441 let consumed = offset' - offset
442 when (consumed /= len)
443 $ fail ("getRecordData " ++ show rt ++ " consumed " ++ show consumed ++
444 " bytes but it had to consume " ++ show len ++ " bytes")
448 getResourceRecord :: RecordClass rc => rt -> rc -> Unpacker DecompTable (ResourceRecord rt rc dt)
449 getResourceRecord rt rc
450 = do name <- getDomainName
451 U.skip 2 -- record type
452 U.skip 2 -- record class
454 dat <- getRecordDataWithLength rt
455 return $ ResourceRecord {
464 data SomeRT = forall rt dt. RecordType rt dt => SomeRT rt
466 instance Show SomeRT where
467 show (SomeRT rt) = show rt
469 instance Eq SomeRT where
470 (SomeRT a) == (SomeRT b) = Just a == cast b
472 getSomeRT :: Unpacker s SomeRT
473 getSomeRT = do n <- liftM fromIntegral U.getWord16be
474 case IM.lookup n defaultRTTable of
476 -> fail ("Unknown resource record type: " ++ show n)
480 data SomeRC = forall rc. RecordClass rc => SomeRC rc
482 instance Show SomeRC where
483 show (SomeRC rc) = show rc
485 instance Eq SomeRC where
486 (SomeRC a) == (SomeRC b) = Just a == cast b
488 getSomeRC :: Unpacker s SomeRC
489 getSomeRC = do n <- liftM fromIntegral U.getWord16be
490 case IM.lookup n defaultRCTable of
492 -> fail ("Unknown resource record class: " ++ show n)
499 soaMasterNameServer :: !DomainName
500 , soaResponsibleMailbox :: !DomainName
501 , soaSerialNumber :: !Word32
502 , soaRefreshInterval :: !Word32
503 , soaRetryInterval :: !Word32
504 , soaExpirationLimit :: !Word32
505 , soaMinimumTTL :: !Word32
507 deriving (Show, Eq, Typeable)
511 wksAddress :: !HostAddress
512 , wksProtocol :: !ProtocolNumber
513 , wksServices :: !IntSet
515 deriving (Show, Eq, Typeable)
518 data A = A deriving (Show, Eq, Typeable)
519 instance RecordType A HostAddress where
521 putRecordData _ = P.putWord32be
522 getRecordData _ = U.getWord32be
524 data NS = NS deriving (Show, Eq, Typeable)
525 instance RecordType NS DomainName where
527 putRecordData _ = putDomainName
528 getRecordData _ = getDomainName
530 data MD = MD deriving (Show, Eq, Typeable)
531 instance RecordType MD DomainName where
533 putRecordData _ = putDomainName
534 getRecordData _ = getDomainName
536 data MF = MF deriving (Show, Eq, Typeable)
537 instance RecordType MF DomainName where
539 putRecordData _ = putDomainName
540 getRecordData _ = getDomainName
542 data CNAME = CNAME deriving (Show, Eq, Typeable)
543 instance RecordType CNAME DomainName where
545 putRecordData _ = putDomainName
546 getRecordData _ = getDomainName
548 data SOA = SOA deriving (Show, Eq, Typeable)
549 instance RecordType SOA SOAFields where
551 putRecordData _ = \ soa ->
552 do putDomainName $ soaMasterNameServer soa
553 putDomainName $ soaResponsibleMailbox soa
554 P.putWord32be $ soaSerialNumber soa
555 P.putWord32be $ soaRefreshInterval soa
556 P.putWord32be $ soaRetryInterval soa
557 P.putWord32be $ soaExpirationLimit soa
558 P.putWord32be $ soaMinimumTTL soa
559 getRecordData _ = do master <- getDomainName
560 mail <- getDomainName
561 serial <- U.getWord32be
562 refresh <- U.getWord32be
563 retry <- U.getWord32be
564 expire <- U.getWord32be
567 soaMasterNameServer = master
568 , soaResponsibleMailbox = mail
569 , soaSerialNumber = serial
570 , soaRefreshInterval = refresh
571 , soaRetryInterval = retry
572 , soaExpirationLimit = expire
573 , soaMinimumTTL = ttl
576 data MB = MB deriving (Show, Eq, Typeable)
577 instance RecordType MB DomainName where
579 putRecordData _ = putDomainName
580 getRecordData _ = getDomainName
582 data MG = MG deriving (Show, Eq, Typeable)
583 instance RecordType MG DomainName where
585 putRecordData _ = putDomainName
586 getRecordData _ = getDomainName
588 data MR = MR deriving (Show, Eq, Typeable)
589 instance RecordType MR DomainName where
591 putRecordData _ = putDomainName
592 getRecordData _ = getDomainName
594 data NULL = NULL deriving (Show, Eq, Typeable)
595 instance RecordType NULL BS.ByteString where
597 putRecordData _ _ = fail "putRecordData NULL can't be defined"
598 getRecordData _ = fail "getRecordData NULL can't be defined"
599 putRecordDataWithLength _ = \ dat ->
600 do P.putWord16be $ fromIntegral $ BS.length dat
602 getRecordDataWithLength _ = do len <- U.getWord16be
603 U.getByteString $ fromIntegral len
605 data WKS = WKS deriving (Show, Eq, Typeable)
606 instance RecordType WKS WKSFields where
608 putRecordData _ = \ wks ->
609 do P.putWord32be $ wksAddress wks
610 P.putWord8 $ fromIntegral $ wksProtocol wks
611 P.putLazyByteString $ toBitmap $ wksServices wks
613 toBitmap :: IntSet -> LBS.ByteString
615 = let maxPort = IS.findMax is
616 range = [0 .. maxPort]
617 isAvail p = p `IS.member` is
619 runBitPut $ mapM_ putBit $ map isAvail range
620 getRecordData _ = fail "getRecordData WKS can't be defined"
622 getRecordDataWithLength _
623 = do len <- U.getWord16be
624 addr <- U.getWord32be
625 proto <- liftM fromIntegral U.getWord8
626 bits <- U.getByteString $ fromIntegral $ len - 4 - 1
629 , wksProtocol = proto
630 , wksServices = fromBitmap bits
633 fromBitmap :: BS.ByteString -> IntSet
635 = let Right is = runBitGet bs $ worker 0 IS.empty
639 worker :: Int -> IntSet -> BitGet IntSet
641 = do remain <- BG.remaining
647 worker (pos + 1) (IS.insert pos is)
652 data PTR = PTR deriving (Show, Eq, Typeable)
653 instance RecordType PTR DomainName where
655 putRecordData _ = putDomainName
656 getRecordData _ = getDomainName
658 data HINFO = HINFO deriving (Show, Eq, Typeable)
659 instance RecordType HINFO (BS.ByteString, BS.ByteString) where
661 putRecordData _ = \ (cpu, os) ->
664 getRecordData _ = do cpu <- getCharString
668 data MINFO = MINFO deriving (Show, Eq, Typeable)
669 instance RecordType MINFO (DomainName, DomainName) where
671 putRecordData _ = \ (r, e) ->
674 getRecordData _ = do r <- getDomainName
678 data MX = MX deriving (Show, Eq, Typeable)
679 instance RecordType MX (Word16, DomainName) where
681 putRecordData _ = \ (pref, exch) ->
682 do P.putWord16be pref
684 getRecordData _ = do pref <- U.getWord16be
685 exch <- getDomainName
688 data TXT = TXT deriving (Show, Eq, Typeable)
689 instance RecordType TXT [BS.ByteString] where
691 putRecordData _ = mapM_ putCharString
692 getRecordData _ = fail "getRecordData TXT can't be defined"
694 getRecordDataWithLength _ = U.getWord16be >>= worker [] . fromIntegral
696 worker :: [BS.ByteString] -> Int -> Unpacker s [BS.ByteString]
697 worker soFar 0 = return (reverse soFar)
698 worker soFar n = do str <- getCharString
699 worker (str : soFar) (0 `max` n - 1 - BS.length str)
701 data AXFR = AXFR deriving (Show, Eq, Typeable)
702 instance QueryType AXFR where
705 data MAILB = MAILB deriving (Show, Eq, Typeable)
706 instance QueryType MAILB where
709 data MAILA = MAILA deriving (Show, Eq, Typeable)
710 instance QueryType MAILA where
713 data ANY = ANY deriving (Show, Eq, Typeable)
714 instance QueryType ANY where
716 instance QueryClass ANY where
719 data IN = IN deriving (Show, Eq, Typeable)
720 instance RecordClass IN where
723 data CS = CS deriving (Show, Eq, Typeable)
724 instance RecordClass CS where
727 data CH = CH deriving (Show, Eq, Typeable)
728 instance RecordClass CH where
731 data HS = HS deriving (Show, Eq, Typeable)
732 instance RecordClass HS where
736 instance Binary Message where
737 put m = P.liftToBinary M.empty $
738 do putBinary $ msgHeader m
739 P.putWord16be $ fromIntegral $ length $ msgQuestions m
740 P.putWord16be $ fromIntegral $ length $ msgAnswers m
741 P.putWord16be $ fromIntegral $ length $ msgAuthorities m
742 P.putWord16be $ fromIntegral $ length $ msgAdditionals m
743 mapM_ putSomeQ $ msgQuestions m
744 mapM_ putSomeRR $ msgAnswers m
745 mapM_ putSomeRR $ msgAuthorities m
746 mapM_ putSomeRR $ msgAdditionals m
748 get = U.liftToBinary IM.empty $
750 nQ <- liftM fromIntegral U.getWord16be
751 nAns <- liftM fromIntegral U.getWord16be
752 nAth <- liftM fromIntegral U.getWord16be
753 nAdd <- liftM fromIntegral U.getWord16be
754 qs <- replicateM nQ getSomeQ
755 anss <- replicateM nAns getSomeRR
756 aths <- replicateM nAth getSomeRR
757 adds <- replicateM nAdd getSomeRR
762 , msgAuthorities = aths
763 , msgAdditionals = adds
766 instance Binary Header where
767 put h = do P'.putWord16be $ hdMessageID h
768 P'.putLazyByteString flags
771 do putNBits 1 $ fromEnum $ hdMessageType h
772 putNBits 4 $ fromEnum $ hdOpcode h
773 putBit $ hdIsAuthoritativeAnswer h
774 putBit $ hdIsTruncated h
775 putBit $ hdIsRecursionDesired h
776 putBit $ hdIsRecursionAvailable h
777 putNBits 3 (0 :: Int)
778 putNBits 4 $ fromEnum $ hdResponseCode h
780 get = do mID <- G.getWord16be
781 flags <- G.getByteString 2
784 do qr <- liftM (toEnum . fromIntegral) $ getAsWord8 1
785 op <- liftM (toEnum . fromIntegral) $ getAsWord8 4
791 rc <- liftM (toEnum . fromIntegral) $ getAsWord8 4
796 , hdIsAuthoritativeAnswer = aa
798 , hdIsRecursionDesired = rd
799 , hdIsRecursionAvailable = ra
800 , hdResponseCode = rc
804 instance Enum MessageType where
806 fromEnum Response = 1
812 instance Enum Opcode where
813 fromEnum StandardQuery = 0
814 fromEnum InverseQuery = 1
815 fromEnum ServerStatusRequest = 2
817 toEnum 0 = StandardQuery
818 toEnum 1 = InverseQuery
819 toEnum 2 = ServerStatusRequest
822 instance Enum ResponseCode where
824 fromEnum FormatError = 1
825 fromEnum ServerFailure = 2
826 fromEnum NameError = 3
827 fromEnum NotImplemented = 4
831 toEnum 1 = FormatError
832 toEnum 2 = ServerFailure
834 toEnum 4 = NotImplemented
839 defaultRTTable :: IntMap SomeRT
840 defaultRTTable = IM.fromList $ map toPair $
859 toPair :: SomeRT -> (Int, SomeRT)
860 toPair srt@(SomeRT rt) = (rtToInt rt, srt)
862 defaultQTTable :: IntMap SomeQT
863 defaultQTTable = mergeWithRTTable defaultRTTable $ IM.fromList $ map toPair $
870 toPair :: SomeQT -> (Int, SomeQT)
871 toPair sqt@(SomeQT qt) = (qtToInt qt, sqt)
873 mergeWithRTTable :: IntMap SomeRT -> IntMap SomeQT -> IntMap SomeQT
874 mergeWithRTTable rts qts
875 = IM.union (toQTTable rts) qts
877 toQTTable :: IntMap SomeRT -> IntMap SomeQT
878 toQTTable = IM.map toSomeQT
880 toSomeQT :: SomeRT -> SomeQT
881 toSomeQT (SomeRT rt) = SomeQT rt
883 defaultRCTable :: IntMap SomeRC
884 defaultRCTable = IM.fromList $ map toPair $
891 toPair :: SomeRC -> (Int, SomeRC)
892 toPair src@(SomeRC rc) = (rcToInt rc, src)
894 defaultQCTable :: IntMap SomeQC
895 defaultQCTable = mergeWithRCTable defaultRCTable $ IM.fromList $ map toPair $
899 toPair :: SomeQC -> (Int, SomeQC)
900 toPair sqc@(SomeQC qc) = (qcToInt qc, sqc)
902 mergeWithRCTable :: IntMap SomeRC -> IntMap SomeQC -> IntMap SomeQC
903 mergeWithRCTable rcs qcs
904 = IM.union (toQCTable rcs) qcs
906 toQCTable :: IntMap SomeRC -> IntMap SomeQC
907 toQCTable = IM.map toSomeQC
909 toSomeQC :: SomeRC -> SomeQC
910 toSomeQC (SomeRC rc) = SomeQC rc
913 wrapQuestion :: (QueryType qt, QueryClass qc) => Question qt qc -> SomeQ
916 wrapRecord :: (RecordType rt dt, RecordClass rc) => ResourceRecord rt rc dt -> SomeRR