Network/DNS/Message.hs

   1 module Network.DNS.Message
   2     ( Message(..)
   3     , MessageID
   4     , MessageType(..)
   5     , Header(..)
   6     , Opcode(..)
   7     , ResponseCode(..)
   8     , Question(..)
   9     , ResourceRecord(..)
  10     , DomainName
  11     , DomainLabel
  12     , TTL
  13     , RecordType
  14     , RecordClass(..)
  15
  16     , SOAFields(..)
  17     , WKSFields(..)
  18
  19     , SomeQ
  20     , SomeQT
  21     , SomeRR
  22     , SomeRT
  23
  24     , A(..)
  25     , NS(..)
  26     , MD(..)
  27     , MF(..)
  28     , CNAME(..)
  29     , SOA(..)
  30     , MB(..)
  31     , MG(..)
  32     , MR(..)
  33     , NULL(..)
  34     , WKS(..)
  35     , PTR(..)
  36     , HINFO(..)
  37     , MINFO(..)
  38     , MX(..)
  39     , TXT(..)
  40
  41     , AXFR(..)
  42     , MAILB(..)
  43     , MAILA(..)
  44     , ANY(..)
  45
  46     , mkDomainName
  47     , wrapQuestion
  48     , wrapRecord
  49     )
  50     where
  51
  52 import           Control.Exception
  53 import           Control.Monad
  54 import           Data.Binary
  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
  62 import           Data.Typeable
  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
  68 import           Data.Map (Map)
  69 import           Data.Word
  70 import           Network.DNS.Packer as P
  71 import           Network.DNS.Unpacker as U
  72 import           Network.Socket
  73
  74
  75 data Message
  76     = Message {
  77         msgHeader      :: !Header
  78       , msgQuestions   :: ![SomeQ]
  79       , msgAnswers     :: ![SomeRR]
  80       , msgAuthorities :: ![SomeRR]
  81       , msgAdditionals :: ![SomeRR]
  82       }
  83     deriving (Show, Eq)
  84
  85 data Header
  86     = Header {
  87         hdMessageID             :: !MessageID
  88       , hdMessageType           :: !MessageType
  89       , hdOpcode                :: !Opcode
  90       , hdIsAuthoritativeAnswer :: !Bool
  91       , hdIsTruncated           :: !Bool
  92       , hdIsRecursionDesired    :: !Bool
  93       , hdIsRecursionAvailable  :: !Bool
  94       , hdResponseCode          :: !ResponseCode
  95
  96       -- These fields are supressed in this data structure:
  97       -- + QDCOUNT
  98       -- + ANCOUNT
  99       -- + NSCOUNT
 100       -- + ARCOUNT
 101       }
 102     deriving (Show, Eq)
 103
 104 type MessageID = Word16
 105
 106 data MessageType
 107     = Query
 108     | Response
 109     deriving (Show, Eq)
 110
 111 data Opcode
 112     = StandardQuery
 113     | InverseQuery
 114     | ServerStatusRequest
 115     deriving (Show, Eq)
 116
 117 data ResponseCode
 118     = NoError
 119     | FormatError
 120     | ServerFailure
 121     | NameError
 122     | NotImplemented
 123     | Refused
 124     deriving (Show, Eq)
 125
 126 data QueryType qt => Question qt
 127     = Question {
 128         qName  :: !DomainName
 129       , qType  :: !qt
 130       , qClass :: !RecordClass
 131       }
 132     deriving (Typeable)
 133
 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) ++ " }"
 138
 139 instance QueryType qt => Eq (Question qt) where
 140     a == b = qName  a == qName  b &&
 141              qType  a == qType  b &&
 142              qClass a == qClass b
 143
 144 data SomeQ = forall qt. QueryType qt => SomeQ (Question qt)
 145
 146 instance Show SomeQ where
 147     show (SomeQ q) = show q
 148
 149 instance Eq SomeQ where
 150     (SomeQ a) == (SomeQ b) = Just a == cast b
 151
 152 data SomeQT = forall qt. QueryType qt => SomeQT qt
 153
 154 instance Show SomeQT where
 155     show (SomeQT qt) = show qt
 156
 157 instance Eq SomeQT where
 158     (SomeQT a) == (SomeQT b) = Just a == cast b
 159
 160 putSomeQ :: SomeQ -> Packer CompTable ()
 161 putSomeQ (SomeQ q)
 162     = do putDomainName $ qName q
 163          putQueryType $ qType q
 164          putBinary $ qClass q
 165
 166 getSomeQ :: Unpacker DecompTable SomeQ
 167 getSomeQ
 168     = do nm <- getDomainName
 169          ty <- getSomeQT
 170          cl <- getBinary
 171          case ty of
 172            SomeQT qt -> return $ SomeQ $
 173                         Question {
 174                           qName  = nm
 175                         , qType  = qt
 176                         , qClass = cl
 177                         }
 178
 179 getSomeQT :: Unpacker s SomeQT
 180 getSomeQT = do n <- liftM fromIntegral U.getWord16be
 181                case IM.lookup n defaultQTTable of
 182                  Just sqt
 183                      -> return sqt
 184                  Nothing
 185                      -> fail ("Unknown query type: " ++ show n)
 186
 187
 188 newtype DomainName  = DN [DomainLabel] deriving (Eq, Show, Ord, Typeable)
 189 type DomainLabel    = BS.ByteString
 190
 191 rootName :: DomainName
 192 rootName = DN [BS.empty]
 193
 194 isRootName :: DomainName -> Bool
 195 isRootName (DN [_]) = True
 196 isRootName _        = False
 197
 198 consLabel :: DomainLabel -> DomainName -> DomainName
 199 consLabel x (DN ys) = DN (x:ys)
 200
 201 unconsLabel :: DomainName -> (DomainLabel, DomainName)
 202 unconsLabel (DN (x:xs)) = (x, DN xs)
 203 unconsLabel x           = error ("Illegal use of unconsLabel: " ++ show x)
 204
 205 mkDomainName :: String -> DomainName
 206 mkDomainName = DN . mkLabels [] . notEmpty
 207     where
 208       notEmpty :: String -> String
 209       notEmpty xs = assert (not $ null xs) xs
 210
 211       mkLabels :: [DomainLabel] -> String -> [DomainLabel]
 212       mkLabels soFar [] = reverse (C8.empty : soFar)
 213       mkLabels soFar xs = case break (== '.') xs of
 214                             (l, ('.':rest))
 215                                 -> mkLabels (C8.pack l : soFar) rest
 216                             _   -> error ("Illegal domain name: " ++ xs)
 217
 218 data RecordClass
 219     = IN
 220     | CS -- Obsolete
 221     | CH
 222     | HS
 223     | AnyClass -- Only for queries
 224     deriving (Show, Eq)
 225
 226
 227 data RecordType rt dt => ResourceRecord rt dt
 228     = ResourceRecord {
 229         rrName  :: !DomainName
 230       , rrType  :: !rt
 231       , rrClass :: !RecordClass
 232       , rrTTL   :: !TTL
 233       , rrData  :: !dt
 234       }
 235     deriving (Show, Eq, Typeable)
 236
 237
 238 data SomeRR = forall rt dt. RecordType rt dt => SomeRR (ResourceRecord rt dt)
 239
 240 instance Show SomeRR where
 241     show (SomeRR rr) = show rr
 242
 243 instance Eq SomeRR where
 244     (SomeRR a) == (SomeRR b) = Just a == cast b
 245
 246
 247 putSomeRR :: SomeRR -> Packer CompTable ()
 248 putSomeRR (SomeRR rr) = putResourceRecord rr
 249
 250 getSomeRR :: Unpacker DecompTable SomeRR
 251 getSomeRR = do srt <- U.lookAhead $
 252                       do getDomainName -- skip
 253                          getSomeRT
 254                case srt of
 255                  SomeRT rt
 256                      -> getResourceRecord rt >>= return . SomeRR
 257
 258 type CompTable   = Map DomainName Int
 259 type DecompTable = IntMap DomainName
 260 type TTL         = Word32
 261
 262 getDomainName :: Unpacker DecompTable DomainName
 263 getDomainName = worker
 264     where
 265       worker :: Unpacker DecompTable DomainName
 266       worker
 267           = do offset <- U.bytesRead
 268                hdr    <- getLabelHeader
 269                case hdr of
 270                  Offset n
 271                      -> do dt <- U.getState
 272                            case IM.lookup n dt of
 273                              Just name
 274                                  -> return name
 275                              Nothing
 276                                  -> fail ("Illegal offset of label pointer: " ++ show (n, dt))
 277                  Length 0
 278                      -> return rootName
 279                  Length n
 280                      -> do label <- U.getByteString n
 281                            rest  <- worker
 282                            let name = consLabel label rest
 283                            U.modifyState $ IM.insert offset name
 284                            return name
 285
 286       getLabelHeader :: Unpacker s LabelHeader
 287       getLabelHeader
 288           = do header <- U.lookAhead $ U.getByteString 1
 289                let Right h
 290                        = runBitGet header $
 291                          do a <- getBit
 292                             b <- getBit
 293                             n <- liftM fromIntegral (getAsWord8 6)
 294                             case (a, b) of
 295                               ( True,  True) -> return $ Offset n
 296                               (False, False) -> return $ Length n
 297                               _              -> fail "Illegal label header"
 298                case h of
 299                  Offset _
 300                      -> do header' <- U.getByteString 2 -- Pointers have 2 octets.
 301                            let Right h'
 302                                    = runBitGet header' $
 303                                      do BG.skip 2
 304                                         n <- liftM fromIntegral (getAsWord16 14)
 305                                         return $ Offset n
 306                            return h'
 307                  len@(Length _)
 308                      -> do U.skip 1
 309                            return len
 310
 311
 312 getCharString :: Unpacker s BS.ByteString
 313 getCharString = do len <- U.getWord8
 314                    U.getByteString (fromIntegral len)
 315
 316 putCharString :: BS.ByteString -> Packer s ()
 317 putCharString xs = do P.putWord8 $ fromIntegral $ BS.length xs
 318                       P.putByteString xs
 319
 320 data LabelHeader
 321     = Offset !Int
 322     | Length !Int
 323
 324 putDomainName :: DomainName -> Packer CompTable ()
 325 putDomainName name
 326     = do ct <- P.getState
 327          case M.lookup name ct of
 328            Just n
 329                -> do let ptr = runBitPut $
 330                                do putBit True
 331                                   putBit True
 332                                   putNBits 14 n
 333                      P.putLazyByteString ptr
 334            Nothing
 335                -> do offset <- bytesWrote
 336                      P.modifyState $ M.insert name offset
 337
 338                      let (label, rest) = unconsLabel name
 339
 340                      putCharString label
 341
 342                      if isRootName rest then
 343                          P.putWord8 0
 344                        else
 345                          putDomainName rest
 346
 347 class (Show qt, Eq qt, Typeable qt) => QueryType qt where
 348     qtToInt :: qt -> Int
 349
 350     putQueryType :: qt -> Packer s ()
 351     putQueryType = P.putWord16be . fromIntegral . qtToInt
 352
 353 instance RecordType rt dt => QueryType rt where
 354     qtToInt = rtToInt
 355
 356 class (Show rt, Show dt, Eq rt, Eq dt, Typeable rt, Typeable dt) => RecordType rt dt | rt -> dt where
 357     rtToInt       :: rt -> Int
 358     putRecordData :: rt -> dt -> Packer CompTable ()
 359     getRecordData :: rt -> Unpacker DecompTable dt
 360
 361     putRecordType :: rt -> Packer s ()
 362     putRecordType = P.putWord16be . fromIntegral . rtToInt
 363
 364     putRecordDataWithLength :: rt -> dt -> Packer CompTable ()
 365     putRecordDataWithLength rt dt
 366         = do -- First, write a dummy data length.
 367              offset <- bytesWrote
 368              P.putWord16be 0
 369
 370              -- Second, write data.
 371              putRecordData rt dt
 372
 373              -- Third, rewrite the dummy length to an actual value.
 374              offset' <- bytesWrote
 375              let len = offset' - offset - 2
 376              if len <= 0xFFFF then
 377                  withOffset offset
 378                     $ P.putWord16be $ fromIntegral len
 379                else
 380                  fail ("putRecordData " ++ show rt ++ " wrote " ++ show len
 381                        ++ " bytes, which is way too long")
 382
 383     putResourceRecord :: ResourceRecord rt dt -> Packer CompTable ()
 384     putResourceRecord rr
 385         = do putDomainName $ rrName  rr
 386              putRecordType $ rrType  rr
 387              putBinary     $ rrClass rr
 388              P.putWord32be $ rrTTL   rr
 389              putRecordDataWithLength (rrType rr) (rrData rr)
 390
 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
 397
 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")
 402
 403              return dat
 404
 405     getResourceRecord :: rt -> Unpacker DecompTable (ResourceRecord rt dt)
 406     getResourceRecord rt
 407         = do name     <- getDomainName
 408              U.skip 2 -- record type
 409              cl       <- getBinary
 410              ttl      <- U.getWord32be
 411              dat      <- getRecordDataWithLength rt
 412              return $ ResourceRecord {
 413                           rrName  = name
 414                         , rrType  = rt
 415                         , rrClass = cl
 416                         , rrTTL   = ttl
 417                         , rrData  = dat
 418                         }
 419
 420 data SomeRT = forall rt dt. RecordType rt dt => SomeRT rt
 421
 422 instance Show SomeRT where
 423     show (SomeRT rt) = show rt
 424
 425 instance Eq SomeRT where
 426     (SomeRT a) == (SomeRT b) = Just a == cast b
 427
 428 getSomeRT :: Unpacker s SomeRT
 429 getSomeRT = do n <- liftM fromIntegral U.getWord16be
 430                case IM.lookup n defaultRTTable of
 431                  Nothing
 432                      -> fail ("Unknown resource record type: " ++ show n)
 433                  Just srt
 434                      -> return srt
 435
 436
 437 data SOAFields
 438     = SOAFields {
 439         soaMasterNameServer   :: !DomainName
 440       , soaResponsibleMailbox :: !DomainName
 441       , soaSerialNumber       :: !Word32
 442       , soaRefreshInterval    :: !Word32
 443       , soaRetryInterval      :: !Word32
 444       , soaExpirationLimit    :: !Word32
 445       , soaMinimumTTL         :: !Word32
 446       }
 447     deriving (Show, Eq, Typeable)
 448
 449 data WKSFields
 450     = WKSFields {
 451         wksAddress  :: !HostAddress
 452       , wksProtocol :: !ProtocolNumber
 453       , wksServices :: !IntSet
 454       }
 455     deriving (Show, Eq, Typeable)
 456
 457
 458 data A = A deriving (Show, Eq, Typeable)
 459 instance RecordType A HostAddress where
 460     rtToInt       _ = 1
 461     putRecordData _ = P.putWord32be
 462     getRecordData _ = U.getWord32be
 463
 464 data NS = NS deriving (Show, Eq, Typeable)
 465 instance RecordType NS DomainName where
 466     rtToInt       _ = 2
 467     putRecordData _ = putDomainName
 468     getRecordData _ = getDomainName
 469
 470 data MD = MD deriving (Show, Eq, Typeable)
 471 instance RecordType MD DomainName where
 472     rtToInt       _ = 3
 473     putRecordData _ = putDomainName
 474     getRecordData _ = getDomainName
 475
 476 data MF = MF deriving (Show, Eq, Typeable)
 477 instance RecordType MF DomainName where
 478     rtToInt       _ = 4
 479     putRecordData _ = putDomainName
 480     getRecordData _ = getDomainName
 481
 482 data CNAME = CNAME deriving (Show, Eq, Typeable)
 483 instance RecordType CNAME DomainName where
 484     rtToInt       _ = 5
 485     putRecordData _ = putDomainName
 486     getRecordData _ = getDomainName
 487
 488 data SOA = SOA deriving (Show, Eq, Typeable)
 489 instance RecordType SOA SOAFields where
 490     rtToInt       _ = 6
 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
 505                          ttl     <- U.getWord32be
 506                          return SOAFields {
 507                                       soaMasterNameServer   = master
 508                                     , soaResponsibleMailbox = mail
 509                                     , soaSerialNumber       = serial
 510                                     , soaRefreshInterval    = refresh
 511                                     , soaRetryInterval      = retry
 512                                     , soaExpirationLimit    = expire
 513                                     , soaMinimumTTL         = ttl
 514                                     }
 515
 516 data MB = MB deriving (Show, Eq, Typeable)
 517 instance RecordType MB DomainName where
 518     rtToInt       _ = 7
 519     putRecordData _ = putDomainName
 520     getRecordData _ = getDomainName
 521
 522 data MG = MG deriving (Show, Eq, Typeable)
 523 instance RecordType MG DomainName where
 524     rtToInt       _ = 8
 525     putRecordData _ = putDomainName
 526     getRecordData _ = getDomainName
 527
 528 data MR = MR deriving (Show, Eq, Typeable)
 529 instance RecordType MR DomainName where
 530     rtToInt       _ = 9
 531     putRecordData _ = putDomainName
 532     getRecordData _ = getDomainName
 533
 534 data NULL = NULL deriving (Show, Eq, Typeable)
 535 instance RecordType NULL BS.ByteString where
 536     rtToInt                 _ = 10
 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
 541                                    P.putByteString dat
 542     getRecordDataWithLength _ = do len <- U.getWord16be
 543                                    U.getByteString $ fromIntegral len
 544
 545 data WKS = WKS deriving (Show, Eq, Typeable)
 546 instance RecordType WKS WKSFields where
 547     rtToInt       _ = 11
 548     putRecordData _ = \ wks ->
 549                       do P.putWord32be $ wksAddress wks
 550                          P.putWord8 $ fromIntegral $ wksProtocol wks
 551                          P.putLazyByteString $ toBitmap $ wksServices wks
 552         where
 553           toBitmap :: IntSet -> LBS.ByteString
 554           toBitmap is
 555               = let maxPort   = IS.findMax is
 556                     range     = [0 .. maxPort]
 557                     isAvail p = p `IS.member` is
 558                 in
 559                   runBitPut $ mapM_ putBit $ map isAvail range
 560     getRecordData _ = fail "getRecordData WKS can't be defined"
 561
 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
 567              return WKSFields {
 568                           wksAddress  = addr
 569                         , wksProtocol = proto
 570                         , wksServices = fromBitmap bits
 571                         }
 572         where
 573           fromBitmap :: BS.ByteString -> IntSet
 574           fromBitmap bs
 575               = let Right is = runBitGet bs $ worker 0 IS.empty
 576                 in
 577                   is
 578
 579           worker :: Int -> IntSet -> BitGet IntSet
 580           worker pos is
 581               = do remain <- BG.remaining
 582                    if remain == 0 then
 583                        return is
 584                      else
 585                        do bit <- getBit
 586                           if bit then
 587                               worker (pos + 1) (IS.insert pos is)
 588                             else
 589                               worker (pos + 1) is
 590
 591
 592 data PTR = PTR deriving (Show, Eq, Typeable)
 593 instance RecordType PTR DomainName where
 594     rtToInt       _ = 12
 595     putRecordData _ = putDomainName
 596     getRecordData _ = getDomainName
 597
 598 data HINFO = HINFO deriving (Show, Eq, Typeable)
 599 instance RecordType HINFO (BS.ByteString, BS.ByteString) where
 600     rtToInt       _ = 13
 601     putRecordData _ = \ (cpu, os) ->
 602                       do putCharString cpu
 603                          putCharString os
 604     getRecordData _ = do cpu <- getCharString
 605                          os  <- getCharString
 606                          return (cpu, os)
 607
 608 data MINFO = MINFO deriving (Show, Eq, Typeable)
 609 instance RecordType MINFO (DomainName, DomainName) where
 610     rtToInt       _ = 14
 611     putRecordData _ = \ (r, e) ->
 612                       do putDomainName r
 613                          putDomainName e
 614     getRecordData _ = do r <- getDomainName
 615                          e <- getDomainName
 616                          return (r, e)
 617
 618 data MX = MX deriving (Show, Eq, Typeable)
 619 instance RecordType MX (Word16, DomainName) where
 620     rtToInt       _ = 15
 621     putRecordData _ = \ (pref, exch) ->
 622                       do P.putWord16be pref
 623                          putDomainName exch
 624     getRecordData _ = do pref <- U.getWord16be
 625                          exch <- getDomainName
 626                          return (pref, exch)
 627
 628 data TXT = TXT deriving (Show, Eq, Typeable)
 629 instance RecordType TXT [BS.ByteString] where
 630     rtToInt       _ = 16
 631     putRecordData _ = mapM_ putCharString
 632     getRecordData _ = fail "getRecordData TXT can't be defined"
 633
 634     getRecordDataWithLength _ = U.getWord16be >>= worker [] . fromIntegral
 635         where
 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)
 640
 641 data AXFR = AXFR deriving (Show, Eq, Typeable)
 642 instance QueryType AXFR where
 643     qtToInt _ = 252
 644
 645 data MAILB = MAILB deriving (Show, Eq, Typeable)
 646 instance QueryType MAILB where
 647     qtToInt _ = 253
 648
 649 data MAILA = MAILA deriving (Show, Eq, Typeable)
 650 instance QueryType MAILA where
 651     qtToInt _ = 254
 652
 653 data ANY = ANY deriving (Show, Eq, Typeable)
 654 instance QueryType ANY where
 655     qtToInt _ = 255
 656
 657
 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
 669
 670     get = U.liftToBinary IM.empty $
 671           do hdr  <- getBinary
 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
 680              return Message {
 681                           msgHeader      = hdr
 682                         , msgQuestions   = qs
 683                         , msgAnswers     = anss
 684                         , msgAuthorities = aths
 685                         , msgAdditionals = adds
 686                         }
 687
 688 instance Binary Header where
 689     put h = do P'.putWord16be $ hdMessageID h
 690                P'.putLazyByteString flags
 691         where
 692           flags = runBitPut $
 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
 701
 702     get = do mID   <- G.getWord16be
 703              flags <- G.getByteString 2
 704              let Right hd
 705                      = runBitGet flags $
 706                        do qr <- liftM (toEnum . fromIntegral) $ getAsWord8 1
 707                           op <- liftM (toEnum . fromIntegral) $ getAsWord8 4
 708                           aa <- getBit
 709                           tc <- getBit
 710                           rd <- getBit
 711                           ra <- getBit
 712                           BG.skip 3
 713                           rc <- liftM (toEnum . fromIntegral) $ getAsWord8 4
 714                           return Header {
 715                                        hdMessageID             = mID
 716                                      , hdMessageType           = qr
 717                                      , hdOpcode                = op
 718                                      , hdIsAuthoritativeAnswer = aa
 719                                      , hdIsTruncated           = tc
 720                                      , hdIsRecursionDesired    = rd
 721                                      , hdIsRecursionAvailable  = ra
 722                                      , hdResponseCode          = rc
 723                                      }
 724              return hd
 725
 726 instance Enum MessageType where
 727     fromEnum Query    = 0
 728     fromEnum Response = 1
 729
 730     toEnum 0 = Query
 731     toEnum 1 = Response
 732     toEnum _ = undefined
 733
 734 instance Enum Opcode where
 735     fromEnum StandardQuery       = 0
 736     fromEnum InverseQuery        = 1
 737     fromEnum ServerStatusRequest = 2
 738
 739     toEnum 0 = StandardQuery
 740     toEnum 1 = InverseQuery
 741     toEnum 2 = ServerStatusRequest
 742     toEnum _ = undefined
 743
 744 instance Enum ResponseCode where
 745     fromEnum NoError        = 0
 746     fromEnum FormatError    = 1
 747     fromEnum ServerFailure  = 2
 748     fromEnum NameError      = 3
 749     fromEnum NotImplemented = 4
 750     fromEnum Refused        = 5
 751
 752     toEnum 0 = NoError
 753     toEnum 1 = FormatError
 754     toEnum 2 = ServerFailure
 755     toEnum 3 = NameError
 756     toEnum 4 = NotImplemented
 757     toEnum 5 = Refused
 758     toEnum _ = undefined
 759
 760 instance Enum RecordClass where
 761     fromEnum IN       = 1
 762     fromEnum CS       = 2
 763     fromEnum CH       = 3
 764     fromEnum HS       = 4
 765     fromEnum AnyClass = 255
 766
 767     toEnum 1   = IN
 768     toEnum 2   = CS
 769     toEnum 3   = CH
 770     toEnum 4   = HS
 771     toEnum 255 = AnyClass
 772     toEnum _   = undefined
 773
 774 instance Binary RecordClass where
 775     get = liftM (toEnum . fromIntegral) G.getWord16be
 776     put = P'.putWord16be . fromIntegral . fromEnum
 777
 778
 779 defaultRTTable :: IntMap SomeRT
 780 defaultRTTable = IM.fromList $ map toPair $
 781                  [ wrapRecordType A
 782                  , wrapRecordType NS
 783                  , wrapRecordType MD
 784                  , wrapRecordType MF
 785                  , wrapRecordType CNAME
 786                  , wrapRecordType SOA
 787                  , wrapRecordType MB
 788                  , wrapRecordType MG
 789                  , wrapRecordType MR
 790                  , wrapRecordType NULL
 791                  , wrapRecordType WKS
 792                  , wrapRecordType PTR
 793                  , wrapRecordType HINFO
 794                  , wrapRecordType MINFO
 795                  , wrapRecordType MX
 796                  , wrapRecordType TXT
 797                  ]
 798     where
 799       toPair :: SomeRT -> (Int, SomeRT)
 800       toPair srt@(SomeRT rt) = (rtToInt rt, srt)
 801
 802
 803 defaultQTTable :: IntMap SomeQT
 804 defaultQTTable = mergeWithRTTable defaultRTTable $ IM.fromList $ map toPair $
 805                  [ wrapQueryType AXFR
 806                  , wrapQueryType MAILB
 807                  , wrapQueryType MAILA
 808                  , wrapQueryType ANY
 809                  ]
 810     where
 811       toPair :: SomeQT -> (Int, SomeQT)
 812       toPair sqt@(SomeQT qt) = (qtToInt qt, sqt)
 813
 814       mergeWithRTTable :: IntMap SomeRT -> IntMap SomeQT -> IntMap SomeQT
 815       mergeWithRTTable rts qts
 816           = IM.union (toQTTable rts) qts
 817
 818       toQTTable :: IntMap SomeRT -> IntMap SomeQT
 819       toQTTable = IM.map toSomeQT
 820
 821       toSomeQT :: SomeRT -> SomeQT
 822       toSomeQT (SomeRT rt) = SomeQT rt
 823
 824
 825 wrapQueryType :: QueryType qt => qt -> SomeQT
 826 wrapQueryType = SomeQT
 827
 828 wrapRecordType :: RecordType rt dt => rt -> SomeRT
 829 wrapRecordType = SomeRT
 830
 831 wrapQuestion :: QueryType qt => Question qt -> SomeQ
 832 wrapQuestion = SomeQ
 833
 834 wrapRecord :: RecordType rt dt => ResourceRecord rt dt -> SomeRR
 835 wrapRecord = SomeRR