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