1 module Network.DNS.Message
58 import Control.Exception
61 import Data.Binary.BitPut as BP
62 import Data.Binary.Get as G
63 import Data.Binary.Put as P'
64 import Data.Binary.Strict.BitGet as BG
65 import qualified Data.ByteString as BS
66 import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
67 import qualified Data.ByteString.Lazy as LBS
69 import qualified Data.IntMap as IM
70 import Data.IntMap (IntMap)
71 import qualified Data.IntSet as IS
72 import Data.IntSet (IntSet)
73 import qualified Data.Map as M
76 import Network.DNS.Packer as P
77 import Network.DNS.Unpacker as U
84 , msgQuestions :: ![SomeQ]
85 , msgAnswers :: ![SomeRR]
86 , msgAuthorities :: ![SomeRR]
87 , msgAdditionals :: ![SomeRR]
93 hdMessageID :: !MessageID
94 , hdMessageType :: !MessageType
96 , hdIsAuthoritativeAnswer :: !Bool
97 , hdIsTruncated :: !Bool
98 , hdIsRecursionDesired :: !Bool
99 , hdIsRecursionAvailable :: !Bool
100 , hdResponseCode :: !ResponseCode
102 -- These fields are supressed in this data structure:
110 type MessageID = Word16
120 | ServerStatusRequest
132 data (QueryType qt, QueryClass qc) => Question qt qc
140 instance (QueryType qt, QueryClass qc) => Show (Question qt qc) where
141 show q = "Question { qName = " ++ show (qName q) ++
142 ", qType = " ++ show (qType q) ++
143 ", qClass = " ++ show (qClass q) ++ " }"
145 instance (QueryType qt, QueryClass qc) => Eq (Question qt qc) where
146 a == b = qName a == qName b &&
147 qType a == qType b &&
150 data SomeQ = forall qt qc. (QueryType qt, QueryClass qc) => SomeQ (Question qt qc)
152 instance Show SomeQ where
153 show (SomeQ q) = show q
155 instance Eq SomeQ where
156 (SomeQ a) == (SomeQ b) = Just a == cast b
158 data SomeQT = forall qt. QueryType qt => SomeQT qt
160 instance Show SomeQT where
161 show (SomeQT qt) = show qt
163 instance Eq SomeQT where
164 (SomeQT a) == (SomeQT b) = Just a == cast b
166 data SomeQC = forall qc. QueryClass qc => SomeQC qc
168 instance Show SomeQC where
169 show (SomeQC qc) = show qc
171 instance Eq SomeQC where
172 (SomeQC a) == (SomeQC b) = Just a == cast b
174 putSomeQ :: SomeQ -> Packer CompTable ()
176 = do putDomainName $ qName q
177 putQueryType $ qType q
178 putQueryClass $ qClass q
180 getSomeQ :: Unpacker DecompTable SomeQ
182 = do nm <- getDomainName
186 (SomeQT qt, SomeQC qc)
187 -> return $ SomeQ $ Question {
193 getSomeQT :: Unpacker s SomeQT
194 getSomeQT = do n <- liftM fromIntegral U.getWord16be
195 case IM.lookup n defaultQTTable of
199 -> fail ("Unknown query type: " ++ show n)
201 getSomeQC :: Unpacker s SomeQC
202 getSomeQC = do n <- liftM fromIntegral U.getWord16be
203 case IM.lookup n defaultQCTable of
207 -> fail ("Unknown query class: " ++ show n)
210 newtype DomainName = DN [DomainLabel] deriving (Eq, Show, Ord, Typeable)
211 type DomainLabel = BS.ByteString
213 rootName :: DomainName
214 rootName = DN [BS.empty]
216 isRootName :: DomainName -> Bool
217 isRootName (DN [_]) = True
220 consLabel :: DomainLabel -> DomainName -> DomainName
221 consLabel x (DN ys) = DN (x:ys)
223 unconsLabel :: DomainName -> (DomainLabel, DomainName)
224 unconsLabel (DN (x:xs)) = (x, DN xs)
225 unconsLabel x = error ("Illegal use of unconsLabel: " ++ show x)
227 mkDomainName :: String -> DomainName
228 mkDomainName = DN . mkLabels [] . notEmpty
230 notEmpty :: String -> String
231 notEmpty xs = assert (not $ null xs) xs
233 mkLabels :: [DomainLabel] -> String -> [DomainLabel]
234 mkLabels soFar [] = reverse (C8.empty : soFar)
235 mkLabels soFar xs = case break (== '.') xs of
237 -> mkLabels (C8.pack l : soFar) rest
238 _ -> error ("Illegal domain name: " ++ xs)
241 class (Show rc, Eq rc, Typeable rc) => RecordClass rc where
244 putRecordClass :: rc -> Packer s ()
245 putRecordClass = P.putWord16be . fromIntegral . rcToInt
248 data (RecordType rt dt, RecordClass rc) => ResourceRecord rt rc dt
250 rrName :: !DomainName
256 deriving (Show, Eq, Typeable)
259 data SomeRR = forall rt rc dt. (RecordType rt dt, RecordClass rc) => SomeRR (ResourceRecord rt rc dt)
261 instance Show SomeRR where
262 show (SomeRR rr) = show rr
264 instance Eq SomeRR where
265 (SomeRR a) == (SomeRR b) = Just a == cast b
268 putSomeRR :: SomeRR -> Packer CompTable ()
269 putSomeRR (SomeRR rr) = putResourceRecord rr
271 getSomeRR :: Unpacker DecompTable SomeRR
272 getSomeRR = do (srt, src) <- U.lookAhead $
273 do getDomainName -- skip
278 (SomeRT rt, SomeRC rc)
279 -> getResourceRecord rt rc >>= return . SomeRR
281 type CompTable = Map DomainName Int
282 type DecompTable = IntMap DomainName
285 getDomainName :: Unpacker DecompTable DomainName
286 getDomainName = worker
288 worker :: Unpacker DecompTable DomainName
290 = do offset <- U.bytesRead
291 hdr <- getLabelHeader
294 -> do dt <- U.getState
295 case IM.lookup n dt of
299 -> fail ("Illegal offset of label pointer: " ++ show (n, dt))
303 -> do label <- U.getByteString n
305 let name = consLabel label rest
306 U.modifyState $ IM.insert offset name
309 getLabelHeader :: Unpacker s LabelHeader
311 = do header <- U.lookAhead $ U.getByteString 1
316 n <- liftM fromIntegral (getAsWord8 6)
318 ( True, True) -> return $ Offset n
319 (False, False) -> return $ Length n
320 _ -> fail "Illegal label header"
323 -> do header' <- U.getByteString 2 -- Pointers have 2 octets.
325 = runBitGet header' $
327 n <- liftM fromIntegral (getAsWord16 14)
335 getCharString :: Unpacker s BS.ByteString
336 getCharString = do len <- U.getWord8
337 U.getByteString (fromIntegral len)
339 putCharString :: BS.ByteString -> Packer s ()
340 putCharString xs = do P.putWord8 $ fromIntegral $ BS.length xs
347 putDomainName :: DomainName -> Packer CompTable ()
349 = do ct <- P.getState
350 case M.lookup name ct of
352 -> do let ptr = runBitPut $
356 P.putLazyByteString ptr
358 -> do offset <- bytesWrote
359 P.modifyState $ M.insert name offset
361 let (label, rest) = unconsLabel name
365 if isRootName rest then
370 class (Show qt, Eq qt, Typeable qt) => QueryType qt where
373 putQueryType :: qt -> Packer s ()
374 putQueryType = P.putWord16be . fromIntegral . qtToInt
376 instance RecordType rt dt => QueryType rt where
379 class (Show qc, Eq qc, Typeable qc) => QueryClass qc where
382 putQueryClass :: qc -> Packer s ()
383 putQueryClass = P.putWord16be . fromIntegral . qcToInt
385 instance RecordClass rc => QueryClass rc where
389 class (Show rt, Show dt, Eq rt, Eq dt, Typeable rt, Typeable dt) => RecordType rt dt | rt -> dt where
391 putRecordData :: rt -> dt -> Packer CompTable ()
392 getRecordData :: rt -> Unpacker DecompTable dt
394 putRecordType :: rt -> Packer s ()
395 putRecordType = P.putWord16be . fromIntegral . rtToInt
397 putRecordDataWithLength :: rt -> dt -> Packer CompTable ()
398 putRecordDataWithLength rt dt
399 = do -- First, write a dummy data length.
403 -- Second, write data.
406 -- Third, rewrite the dummy length to an actual value.
407 offset' <- bytesWrote
408 let len = offset' - offset - 2
409 if len <= 0xFFFF then
411 $ P.putWord16be $ fromIntegral len
413 fail ("putRecordData " ++ show rt ++ " wrote " ++ show len
414 ++ " bytes, which is way too long")
416 putResourceRecord :: RecordClass rc => ResourceRecord rt rc dt -> Packer CompTable ()
418 = do putDomainName $ rrName rr
419 putRecordType $ rrType rr
420 putRecordClass $ rrClass rr
421 P.putWord32be $ rrTTL rr
422 putRecordDataWithLength (rrType rr) (rrData rr)
424 getRecordDataWithLength :: rt -> Unpacker DecompTable dt
425 getRecordDataWithLength rt
426 = do len <- U.getWord16be
427 offset <- U.bytesRead
428 dat <- getRecordData rt
429 offset' <- U.bytesRead
431 let consumed = offset' - offset
432 when (consumed /= len)
433 $ fail ("getRecordData " ++ show rt ++ " consumed " ++ show consumed ++
434 " bytes but it had to consume " ++ show len ++ " bytes")
438 getResourceRecord :: RecordClass rc => rt -> rc -> Unpacker DecompTable (ResourceRecord rt rc dt)
439 getResourceRecord rt rc
440 = do name <- getDomainName
441 U.skip 2 -- record type
442 U.skip 2 -- record class
444 dat <- getRecordDataWithLength rt
445 return $ ResourceRecord {
454 data SomeRT = forall rt dt. RecordType rt dt => SomeRT rt
456 instance Show SomeRT where
457 show (SomeRT rt) = show rt
459 instance Eq SomeRT where
460 (SomeRT a) == (SomeRT b) = Just a == cast b
462 getSomeRT :: Unpacker s SomeRT
463 getSomeRT = do n <- liftM fromIntegral U.getWord16be
464 case IM.lookup n defaultRTTable of
466 -> fail ("Unknown resource record type: " ++ show n)
470 data SomeRC = forall rc. RecordClass rc => SomeRC rc
472 instance Show SomeRC where
473 show (SomeRC rc) = show rc
475 instance Eq SomeRC where
476 (SomeRC a) == (SomeRC b) = Just a == cast b
478 getSomeRC :: Unpacker s SomeRC
479 getSomeRC = do n <- liftM fromIntegral U.getWord16be
480 case IM.lookup n defaultRCTable of
482 -> fail ("Unknown resource record class: " ++ show n)
489 soaMasterNameServer :: !DomainName
490 , soaResponsibleMailbox :: !DomainName
491 , soaSerialNumber :: !Word32
492 , soaRefreshInterval :: !Word32
493 , soaRetryInterval :: !Word32
494 , soaExpirationLimit :: !Word32
495 , soaMinimumTTL :: !Word32
497 deriving (Show, Eq, Typeable)
501 wksAddress :: !HostAddress
502 , wksProtocol :: !ProtocolNumber
503 , wksServices :: !IntSet
505 deriving (Show, Eq, Typeable)
508 data A = A deriving (Show, Eq, Typeable)
509 instance RecordType A HostAddress where
511 putRecordData _ = P.putWord32be
512 getRecordData _ = U.getWord32be
514 data NS = NS deriving (Show, Eq, Typeable)
515 instance RecordType NS DomainName where
517 putRecordData _ = putDomainName
518 getRecordData _ = getDomainName
520 data MD = MD deriving (Show, Eq, Typeable)
521 instance RecordType MD DomainName where
523 putRecordData _ = putDomainName
524 getRecordData _ = getDomainName
526 data MF = MF deriving (Show, Eq, Typeable)
527 instance RecordType MF DomainName where
529 putRecordData _ = putDomainName
530 getRecordData _ = getDomainName
532 data CNAME = CNAME deriving (Show, Eq, Typeable)
533 instance RecordType CNAME DomainName where
535 putRecordData _ = putDomainName
536 getRecordData _ = getDomainName
538 data SOA = SOA deriving (Show, Eq, Typeable)
539 instance RecordType SOA SOAFields where
541 putRecordData _ = \ soa ->
542 do putDomainName $ soaMasterNameServer soa
543 putDomainName $ soaResponsibleMailbox soa
544 P.putWord32be $ soaSerialNumber soa
545 P.putWord32be $ soaRefreshInterval soa
546 P.putWord32be $ soaRetryInterval soa
547 P.putWord32be $ soaExpirationLimit soa
548 P.putWord32be $ soaMinimumTTL soa
549 getRecordData _ = do master <- getDomainName
550 mail <- getDomainName
551 serial <- U.getWord32be
552 refresh <- U.getWord32be
553 retry <- U.getWord32be
554 expire <- U.getWord32be
557 soaMasterNameServer = master
558 , soaResponsibleMailbox = mail
559 , soaSerialNumber = serial
560 , soaRefreshInterval = refresh
561 , soaRetryInterval = retry
562 , soaExpirationLimit = expire
563 , soaMinimumTTL = ttl
566 data MB = MB deriving (Show, Eq, Typeable)
567 instance RecordType MB DomainName where
569 putRecordData _ = putDomainName
570 getRecordData _ = getDomainName
572 data MG = MG deriving (Show, Eq, Typeable)
573 instance RecordType MG DomainName where
575 putRecordData _ = putDomainName
576 getRecordData _ = getDomainName
578 data MR = MR deriving (Show, Eq, Typeable)
579 instance RecordType MR DomainName where
581 putRecordData _ = putDomainName
582 getRecordData _ = getDomainName
584 data NULL = NULL deriving (Show, Eq, Typeable)
585 instance RecordType NULL BS.ByteString where
587 putRecordData _ _ = fail "putRecordData NULL can't be defined"
588 getRecordData _ = fail "getRecordData NULL can't be defined"
589 putRecordDataWithLength _ = \ dat ->
590 do P.putWord16be $ fromIntegral $ BS.length dat
592 getRecordDataWithLength _ = do len <- U.getWord16be
593 U.getByteString $ fromIntegral len
595 data WKS = WKS deriving (Show, Eq, Typeable)
596 instance RecordType WKS WKSFields where
598 putRecordData _ = \ wks ->
599 do P.putWord32be $ wksAddress wks
600 P.putWord8 $ fromIntegral $ wksProtocol wks
601 P.putLazyByteString $ toBitmap $ wksServices wks
603 toBitmap :: IntSet -> LBS.ByteString
605 = let maxPort = IS.findMax is
606 range = [0 .. maxPort]
607 isAvail p = p `IS.member` is
609 runBitPut $ mapM_ putBit $ map isAvail range
610 getRecordData _ = fail "getRecordData WKS can't be defined"
612 getRecordDataWithLength _
613 = do len <- U.getWord16be
614 addr <- U.getWord32be
615 proto <- liftM fromIntegral U.getWord8
616 bits <- U.getByteString $ fromIntegral $ len - 4 - 1
619 , wksProtocol = proto
620 , wksServices = fromBitmap bits
623 fromBitmap :: BS.ByteString -> IntSet
625 = let Right is = runBitGet bs $ worker 0 IS.empty
629 worker :: Int -> IntSet -> BitGet IntSet
631 = do remain <- BG.remaining
637 worker (pos + 1) (IS.insert pos is)
642 data PTR = PTR deriving (Show, Eq, Typeable)
643 instance RecordType PTR DomainName where
645 putRecordData _ = putDomainName
646 getRecordData _ = getDomainName
648 data HINFO = HINFO deriving (Show, Eq, Typeable)
649 instance RecordType HINFO (BS.ByteString, BS.ByteString) where
651 putRecordData _ = \ (cpu, os) ->
654 getRecordData _ = do cpu <- getCharString
658 data MINFO = MINFO deriving (Show, Eq, Typeable)
659 instance RecordType MINFO (DomainName, DomainName) where
661 putRecordData _ = \ (r, e) ->
664 getRecordData _ = do r <- getDomainName
668 data MX = MX deriving (Show, Eq, Typeable)
669 instance RecordType MX (Word16, DomainName) where
671 putRecordData _ = \ (pref, exch) ->
672 do P.putWord16be pref
674 getRecordData _ = do pref <- U.getWord16be
675 exch <- getDomainName
678 data TXT = TXT deriving (Show, Eq, Typeable)
679 instance RecordType TXT [BS.ByteString] where
681 putRecordData _ = mapM_ putCharString
682 getRecordData _ = fail "getRecordData TXT can't be defined"
684 getRecordDataWithLength _ = U.getWord16be >>= worker [] . fromIntegral
686 worker :: [BS.ByteString] -> Int -> Unpacker s [BS.ByteString]
687 worker soFar 0 = return (reverse soFar)
688 worker soFar n = do str <- getCharString
689 worker (str : soFar) (0 `max` n - 1 - BS.length str)
691 data AXFR = AXFR deriving (Show, Eq, Typeable)
692 instance QueryType AXFR where
695 data MAILB = MAILB deriving (Show, Eq, Typeable)
696 instance QueryType MAILB where
699 data MAILA = MAILA deriving (Show, Eq, Typeable)
700 instance QueryType MAILA where
703 data ANY = ANY deriving (Show, Eq, Typeable)
704 instance QueryType ANY where
706 instance QueryClass ANY where
709 data IN = IN deriving (Show, Eq, Typeable)
710 instance RecordClass IN where
713 data CS = CS deriving (Show, Eq, Typeable)
714 instance RecordClass CS where
717 data CH = CH deriving (Show, Eq, Typeable)
718 instance RecordClass CH where
721 data HS = HS deriving (Show, Eq, Typeable)
722 instance RecordClass HS where
726 instance Binary Message where
727 put m = P.liftToBinary M.empty $
728 do putBinary $ msgHeader m
729 P.putWord16be $ fromIntegral $ length $ msgQuestions m
730 P.putWord16be $ fromIntegral $ length $ msgAnswers m
731 P.putWord16be $ fromIntegral $ length $ msgAuthorities m
732 P.putWord16be $ fromIntegral $ length $ msgAdditionals m
733 mapM_ putSomeQ $ msgQuestions m
734 mapM_ putSomeRR $ msgAnswers m
735 mapM_ putSomeRR $ msgAuthorities m
736 mapM_ putSomeRR $ msgAdditionals m
738 get = U.liftToBinary IM.empty $
740 nQ <- liftM fromIntegral U.getWord16be
741 nAns <- liftM fromIntegral U.getWord16be
742 nAth <- liftM fromIntegral U.getWord16be
743 nAdd <- liftM fromIntegral U.getWord16be
744 qs <- replicateM nQ getSomeQ
745 anss <- replicateM nAns getSomeRR
746 aths <- replicateM nAth getSomeRR
747 adds <- replicateM nAdd getSomeRR
752 , msgAuthorities = aths
753 , msgAdditionals = adds
756 instance Binary Header where
757 put h = do P'.putWord16be $ hdMessageID h
758 P'.putLazyByteString flags
761 do putNBits 1 $ fromEnum $ hdMessageType h
762 putNBits 4 $ fromEnum $ hdOpcode h
763 putBit $ hdIsAuthoritativeAnswer h
764 putBit $ hdIsTruncated h
765 putBit $ hdIsRecursionDesired h
766 putBit $ hdIsRecursionAvailable h
767 putNBits 3 (0 :: Int)
768 putNBits 4 $ fromEnum $ hdResponseCode h
770 get = do mID <- G.getWord16be
771 flags <- G.getByteString 2
774 do qr <- liftM (toEnum . fromIntegral) $ getAsWord8 1
775 op <- liftM (toEnum . fromIntegral) $ getAsWord8 4
781 rc <- liftM (toEnum . fromIntegral) $ getAsWord8 4
786 , hdIsAuthoritativeAnswer = aa
788 , hdIsRecursionDesired = rd
789 , hdIsRecursionAvailable = ra
790 , hdResponseCode = rc
794 instance Enum MessageType where
796 fromEnum Response = 1
802 instance Enum Opcode where
803 fromEnum StandardQuery = 0
804 fromEnum InverseQuery = 1
805 fromEnum ServerStatusRequest = 2
807 toEnum 0 = StandardQuery
808 toEnum 1 = InverseQuery
809 toEnum 2 = ServerStatusRequest
812 instance Enum ResponseCode where
814 fromEnum FormatError = 1
815 fromEnum ServerFailure = 2
816 fromEnum NameError = 3
817 fromEnum NotImplemented = 4
821 toEnum 1 = FormatError
822 toEnum 2 = ServerFailure
824 toEnum 4 = NotImplemented
829 defaultRTTable :: IntMap SomeRT
830 defaultRTTable = IM.fromList $ map toPair $
849 toPair :: SomeRT -> (Int, SomeRT)
850 toPair srt@(SomeRT rt) = (rtToInt rt, srt)
852 defaultQTTable :: IntMap SomeQT
853 defaultQTTable = mergeWithRTTable defaultRTTable $ IM.fromList $ map toPair $
860 toPair :: SomeQT -> (Int, SomeQT)
861 toPair sqt@(SomeQT qt) = (qtToInt qt, sqt)
863 mergeWithRTTable :: IntMap SomeRT -> IntMap SomeQT -> IntMap SomeQT
864 mergeWithRTTable rts qts
865 = IM.union (toQTTable rts) qts
867 toQTTable :: IntMap SomeRT -> IntMap SomeQT
868 toQTTable = IM.map toSomeQT
870 toSomeQT :: SomeRT -> SomeQT
871 toSomeQT (SomeRT rt) = SomeQT rt
873 defaultRCTable :: IntMap SomeRC
874 defaultRCTable = IM.fromList $ map toPair $
881 toPair :: SomeRC -> (Int, SomeRC)
882 toPair src@(SomeRC rc) = (rcToInt rc, src)
884 defaultQCTable :: IntMap SomeQC
885 defaultQCTable = mergeWithRCTable defaultRCTable $ IM.fromList $ map toPair $
889 toPair :: SomeQC -> (Int, SomeQC)
890 toPair sqc@(SomeQC qc) = (qcToInt qc, sqc)
892 mergeWithRCTable :: IntMap SomeRC -> IntMap SomeQC -> IntMap SomeQC
893 mergeWithRCTable rcs qcs
894 = IM.union (toQCTable rcs) qcs
896 toQCTable :: IntMap SomeRC -> IntMap SomeQC
897 toQCTable = IM.map toSomeQC
899 toSomeQC :: SomeRC -> SomeQC
900 toSomeQC (SomeRC rc) = SomeQC rc
903 wrapQuestion :: (QueryType qt, QueryClass qc) => Question qt qc -> SomeQ
906 wrapRecord :: (RecordType rt dt, RecordClass rc) => ResourceRecord rt rc dt -> SomeRR