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