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