Network/DNS/Message.hs

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