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