module Network.DNS.Message
    ( Message(..)
    , MessageID
    , MessageType(..)
    , Header(..)
    , Opcode(..)
    , ResponseCode(..)
    , Question(..)
    , ResourceRecord(..)
    , DomainName
    , DomainLabel
    , TTL

    , QueryType
    , QueryClass
    , RecordType
    , RecordClass

    , SOAFields(..)
    , WKSFields(..)

    , SomeQ
    , SomeRR

    , A(..)
    , NS(..)
    , MD(..)
    , MF(..)
    , CNAME(..)
    , SOA(..)
    , MB(..)
    , MG(..)
    , MR(..)
    , NULL(..)
    , WKS(..)
    , PTR(..)
    , HINFO(..)
    , MINFO(..)
    , MX(..)
    , TXT(..)

    , AXFR(..)
    , MAILB(..)
    , MAILA(..)
    , ANY(..)

    , IN(..)
    , CS(..)
    , CH(..)
    , HS(..)

    , mkDomainName
    , wrapQuestion
    , wrapRecord
    )
    where

import           Control.Exception
import           Control.Monad
import           Data.Binary
import           Data.Binary.BitPut as BP
import           Data.Binary.Get as G
import           Data.Binary.Put as P'
import           Data.Binary.Strict.BitGet as BG
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
import qualified Data.ByteString.Lazy as LBS
import           Data.Typeable
import qualified Data.IntMap as IM
import           Data.IntMap (IntMap)
import qualified Data.IntSet as IS
import           Data.IntSet (IntSet)
import qualified Data.Map as M
import           Data.Map (Map)
import           Data.Word
import           Network.DNS.Packer as P
import           Network.DNS.Unpacker as U
import           Network.Socket


data Message
    = Message {
        msgHeader      :: !Header
      , msgQuestions   :: ![SomeQ]
      , msgAnswers     :: ![SomeRR]
      , msgAuthorities :: ![SomeRR]
      , msgAdditionals :: ![SomeRR]
      }
    deriving (Show, Eq)

data Header
    = Header {
        hdMessageID             :: !MessageID
      , hdMessageType           :: !MessageType
      , hdOpcode                :: !Opcode
      , hdIsAuthoritativeAnswer :: !Bool
      , hdIsTruncated           :: !Bool
      , hdIsRecursionDesired    :: !Bool
      , hdIsRecursionAvailable  :: !Bool
      , hdResponseCode          :: !ResponseCode

      -- These fields are supressed in this data structure:
      -- + QDCOUNT
      -- + ANCOUNT
      -- + NSCOUNT
      -- + ARCOUNT
      }
    deriving (Show, Eq)

type MessageID = Word16

data MessageType
    = Query
    | Response
    deriving (Show, Eq)

data Opcode
    = StandardQuery
    | InverseQuery
    | ServerStatusRequest
    deriving (Show, Eq)

data ResponseCode
    = NoError
    | FormatError
    | ServerFailure
    | NameError
    | NotImplemented
    | Refused
    deriving (Show, Eq)

data (QueryType qt, QueryClass qc) => Question qt qc
    = Question {
        qName  :: !DomainName
      , qType  :: !qt
      , qClass :: !qc
      }
    deriving (Typeable)

instance (QueryType qt, QueryClass qc) => Show (Question qt qc) where
    show q = "Question { qName = " ++ show (qName q) ++
             ", qType = " ++ show (qType q) ++
             ", qClass = " ++ show (qClass q) ++ " }"

instance (QueryType qt, QueryClass qc) => Eq (Question qt qc) where
    a == b = qName  a == qName  b &&
             qType  a == qType  b &&
             qClass a == qClass b

data SomeQ = forall qt qc. (QueryType qt, QueryClass qc) => SomeQ (Question qt qc)

instance Show SomeQ where
    show (SomeQ q) = show q

instance Eq SomeQ where
    (SomeQ a) == (SomeQ b) = Just a == cast b

data SomeQT = forall qt. QueryType qt => SomeQT qt

instance Show SomeQT where
    show (SomeQT qt) = show qt

instance Eq SomeQT where
    (SomeQT a) == (SomeQT b) = Just a == cast b

data SomeQC = forall qc. QueryClass qc => SomeQC qc

instance Show SomeQC where
    show (SomeQC qc) = show qc

instance Eq SomeQC where
    (SomeQC a) == (SomeQC b) = Just a == cast b

putSomeQ :: SomeQ -> Packer CompTable ()
putSomeQ (SomeQ q)
    = do putDomainName $ qName q
         putQueryType  $ qType q
         putQueryClass $ qClass q

getSomeQ :: Unpacker DecompTable SomeQ
getSomeQ
    = do nm <- getDomainName
         ty <- getSomeQT
         cl <- getSomeQC
         case (ty, cl) of
           (SomeQT qt, SomeQC qc)
               -> return $ SomeQ $ Question {
                         qName  = nm
                       , qType  = qt
                       , qClass = qc
                       }

getSomeQT :: Unpacker s SomeQT
getSomeQT = do n <- liftM fromIntegral U.getWord16be
               case IM.lookup n defaultQTTable of
                 Just sqt
                     -> return sqt
                 Nothing
                     -> fail ("Unknown query type: " ++ show n)

getSomeQC :: Unpacker s SomeQC
getSomeQC = do n <- liftM fromIntegral U.getWord16be
               case IM.lookup n defaultQCTable of
                 Just sqc
                     -> return sqc
                 Nothing
                     -> fail ("Unknown query class: " ++ show n)


newtype DomainName  = DN [DomainLabel] deriving (Eq, Show, Ord, Typeable)
type DomainLabel    = BS.ByteString

rootName :: DomainName
rootName = DN [BS.empty]

isRootName :: DomainName -> Bool
isRootName (DN [_]) = True
isRootName _        = False

consLabel :: DomainLabel -> DomainName -> DomainName
consLabel x (DN ys) = DN (x:ys)

unconsLabel :: DomainName -> (DomainLabel, DomainName)
unconsLabel (DN (x:xs)) = (x, DN xs)
unconsLabel x           = error ("Illegal use of unconsLabel: " ++ show x)

mkDomainName :: String -> DomainName
mkDomainName = DN . mkLabels [] . notEmpty
    where
      notEmpty :: String -> String
      notEmpty xs = assert (not $ null xs) xs

      mkLabels :: [DomainLabel] -> String -> [DomainLabel]
      mkLabels soFar [] = reverse (C8.empty : soFar)
      mkLabels soFar xs = case break (== '.') xs of
                            (l, ('.':rest))
                                -> mkLabels (C8.pack l : soFar) rest
                            _   -> error ("Illegal domain name: " ++ xs)


class (Show rc, Eq rc, Typeable rc) => RecordClass rc where
    rcToInt :: rc -> Int

    putRecordClass :: rc -> Packer s ()
    putRecordClass = P.putWord16be . fromIntegral . rcToInt


data (RecordType rt dt, RecordClass rc) => ResourceRecord rt rc dt
    = ResourceRecord {
        rrName  :: !DomainName
      , rrType  :: !rt
      , rrClass :: !rc
      , rrTTL   :: !TTL
      , rrData  :: !dt
      }
    deriving (Show, Eq, Typeable)


data SomeRR = forall rt rc dt. (RecordType rt dt, RecordClass rc) => SomeRR (ResourceRecord rt rc dt)

instance Show SomeRR where
    show (SomeRR rr) = show rr

instance Eq SomeRR where
    (SomeRR a) == (SomeRR b) = Just a == cast b


putSomeRR :: SomeRR -> Packer CompTable ()
putSomeRR (SomeRR rr) = putResourceRecord rr

getSomeRR :: Unpacker DecompTable SomeRR
getSomeRR = do (srt, src) <- U.lookAhead $
                             do getDomainName -- skip
                                srt <- getSomeRT
                                src <- getSomeRC
                                return (srt, src)
               case (srt, src) of
                 (SomeRT rt, SomeRC rc)
                     -> getResourceRecord rt rc >>= return . SomeRR

type CompTable   = Map DomainName Int
type DecompTable = IntMap DomainName
type TTL         = Word32

getDomainName :: Unpacker DecompTable DomainName
getDomainName = worker
    where
      worker :: Unpacker DecompTable DomainName
      worker
          = do offset <- U.bytesRead
               hdr    <- getLabelHeader
               case hdr of
                 Offset n
                     -> do dt <- U.getState
                           case IM.lookup n dt of
                             Just name
                                 -> return name
                             Nothing
                                 -> fail ("Illegal offset of label pointer: " ++ show (n, dt))
                 Length 0
                     -> return rootName
                 Length n
                     -> do label <- U.getByteString n
                           rest  <- worker
                           let name = consLabel label rest
                           U.modifyState $ IM.insert offset name
                           return name

      getLabelHeader :: Unpacker s LabelHeader
      getLabelHeader
          = do header <- U.lookAhead $ U.getByteString 1
               let Right h
                       = runBitGet header $
                         do a <- getBit
                            b <- getBit
                            n <- liftM fromIntegral (getAsWord8 6)
                            case (a, b) of
                              ( True,  True) -> return $ Offset n
                              (False, False) -> return $ Length n
                              _              -> fail "Illegal label header"
               case h of
                 Offset _
                     -> do header' <- U.getByteString 2 -- Pointers have 2 octets.
                           let Right h'
                                   = runBitGet header' $
                                     do BG.skip 2
                                        n <- liftM fromIntegral (getAsWord16 14)
                                        return $ Offset n
                           return h'
                 len@(Length _)
                     -> do U.skip 1
                           return len


getCharString :: Unpacker s BS.ByteString
getCharString = do len <- U.getWord8
                   U.getByteString (fromIntegral len)

putCharString :: BS.ByteString -> Packer s ()
putCharString xs = do P.putWord8 $ fromIntegral $ BS.length xs
                      P.putByteString xs

data LabelHeader
    = Offset !Int
    | Length !Int

putDomainName :: DomainName -> Packer CompTable ()
putDomainName name
    = do ct <- P.getState
         case M.lookup name ct of
           Just n
               -> do let ptr = runBitPut $
                               do putBit True
                                  putBit True
                                  putNBits 14 n
                     P.putLazyByteString ptr
           Nothing
               -> do offset <- bytesWrote
                     P.modifyState $ M.insert name offset

                     let (label, rest) = unconsLabel name

                     putCharString label

                     if isRootName rest then
                         P.putWord8 0
                       else
                         putDomainName rest

class (Show qt, Eq qt, Typeable qt) => QueryType qt where
    qtToInt :: qt -> Int

    putQueryType :: qt -> Packer s ()
    putQueryType = P.putWord16be . fromIntegral . qtToInt

instance RecordType rt dt => QueryType rt where
    qtToInt = rtToInt

class (Show qc, Eq qc, Typeable qc) => QueryClass qc where
    qcToInt :: qc -> Int

    putQueryClass :: qc -> Packer s ()
    putQueryClass = P.putWord16be . fromIntegral . qcToInt

instance RecordClass rc => QueryClass rc where
    qcToInt = rcToInt


class (Show rt, Show dt, Eq rt, Eq dt, Typeable rt, Typeable dt) => RecordType rt dt | rt -> dt where
    rtToInt       :: rt -> Int
    putRecordData :: rt -> dt -> Packer CompTable ()
    getRecordData :: rt -> Unpacker DecompTable dt

    putRecordType :: rt -> Packer s ()
    putRecordType = P.putWord16be . fromIntegral . rtToInt

    putRecordDataWithLength :: rt -> dt -> Packer CompTable ()
    putRecordDataWithLength rt dt
        = do -- First, write a dummy data length.
             offset <- bytesWrote
             P.putWord16be 0

             -- Second, write data.
             putRecordData rt dt

             -- Third, rewrite the dummy length to an actual value.
             offset' <- bytesWrote
             let len = offset' - offset - 2
             if len <= 0xFFFF then
                 withOffset offset
                    $ P.putWord16be $ fromIntegral len
               else
                 fail ("putRecordData " ++ show rt ++ " wrote " ++ show len
                       ++ " bytes, which is way too long")

    putResourceRecord :: RecordClass rc => ResourceRecord rt rc dt -> Packer CompTable ()
    putResourceRecord rr
        = do putDomainName  $ rrName  rr
             putRecordType  $ rrType  rr
             putRecordClass $ rrClass rr
             P.putWord32be  $ rrTTL   rr
             putRecordDataWithLength (rrType rr) (rrData rr)

    getRecordDataWithLength :: rt -> Unpacker DecompTable dt
    getRecordDataWithLength rt
        = do len     <- U.getWord16be
             offset  <- U.bytesRead
             dat     <- getRecordData rt
             offset' <- U.bytesRead

             let consumed = offset' - offset
             when (consumed /= len)
                      $ fail ("getRecordData " ++ show rt ++ " consumed " ++ show consumed ++
                              " bytes but it had to consume " ++ show len ++ " bytes")

             return dat

    getResourceRecord :: RecordClass rc => rt -> rc -> Unpacker DecompTable (ResourceRecord rt rc dt)
    getResourceRecord rt rc
        = do name     <- getDomainName
             U.skip 2 -- record type
             U.skip 2 -- record class
             ttl      <- U.getWord32be
             dat      <- getRecordDataWithLength rt
             return $ ResourceRecord {
                          rrName  = name
                        , rrType  = rt
                        , rrClass = rc
                        , rrTTL   = ttl
                        , rrData  = dat
                        }


data SomeRT = forall rt dt. RecordType rt dt => SomeRT rt

instance Show SomeRT where
    show (SomeRT rt) = show rt

instance Eq SomeRT where
    (SomeRT a) == (SomeRT b) = Just a == cast b

getSomeRT :: Unpacker s SomeRT
getSomeRT = do n <- liftM fromIntegral U.getWord16be
               case IM.lookup n defaultRTTable of
                 Nothing
                     -> fail ("Unknown resource record type: " ++ show n)
                 Just srt
                     -> return srt

data SomeRC = forall rc. RecordClass rc => SomeRC rc

instance Show SomeRC where
    show (SomeRC rc) = show rc

instance Eq SomeRC where
    (SomeRC a) == (SomeRC b) = Just a == cast b

getSomeRC :: Unpacker s SomeRC
getSomeRC = do n <- liftM fromIntegral U.getWord16be
               case IM.lookup n defaultRCTable of
                 Nothing
                     -> fail ("Unknown resource record class: " ++ show n)
                 Just src
                     -> return src


data SOAFields
    = SOAFields {
        soaMasterNameServer   :: !DomainName
      , soaResponsibleMailbox :: !DomainName
      , soaSerialNumber       :: !Word32
      , soaRefreshInterval    :: !Word32
      , soaRetryInterval      :: !Word32
      , soaExpirationLimit    :: !Word32
      , soaMinimumTTL         :: !Word32
      }
    deriving (Show, Eq, Typeable)

data WKSFields
    = WKSFields {
        wksAddress  :: !HostAddress
      , wksProtocol :: !ProtocolNumber
      , wksServices :: !IntSet
      }
    deriving (Show, Eq, Typeable)


data A = A deriving (Show, Eq, Typeable)
instance RecordType A HostAddress where
    rtToInt       _ = 1
    putRecordData _ = P.putWord32be
    getRecordData _ = U.getWord32be

data NS = NS deriving (Show, Eq, Typeable)
instance RecordType NS DomainName where
    rtToInt       _ = 2
    putRecordData _ = putDomainName
    getRecordData _ = getDomainName

data MD = MD deriving (Show, Eq, Typeable)
instance RecordType MD DomainName where
    rtToInt       _ = 3
    putRecordData _ = putDomainName
    getRecordData _ = getDomainName

data MF = MF deriving (Show, Eq, Typeable)
instance RecordType MF DomainName where
    rtToInt       _ = 4
    putRecordData _ = putDomainName
    getRecordData _ = getDomainName

data CNAME = CNAME deriving (Show, Eq, Typeable)
instance RecordType CNAME DomainName where
    rtToInt       _ = 5
    putRecordData _ = putDomainName
    getRecordData _ = getDomainName

data SOA = SOA deriving (Show, Eq, Typeable)
instance RecordType SOA SOAFields where
    rtToInt       _ = 6
    putRecordData _ = \ soa ->
                      do putDomainName $ soaMasterNameServer soa
                         putDomainName $ soaResponsibleMailbox soa
                         P.putWord32be $ soaSerialNumber soa
                         P.putWord32be $ soaRefreshInterval soa
                         P.putWord32be $ soaRetryInterval soa
                         P.putWord32be $ soaExpirationLimit soa
                         P.putWord32be $ soaMinimumTTL soa
    getRecordData _ = do master  <- getDomainName
                         mail    <- getDomainName
                         serial  <- U.getWord32be
                         refresh <- U.getWord32be
                         retry   <- U.getWord32be
                         expire  <- U.getWord32be
                         ttl     <- U.getWord32be
                         return SOAFields {
                                      soaMasterNameServer   = master
                                    , soaResponsibleMailbox = mail
                                    , soaSerialNumber       = serial
                                    , soaRefreshInterval    = refresh
                                    , soaRetryInterval      = retry
                                    , soaExpirationLimit    = expire
                                    , soaMinimumTTL         = ttl
                                    }

data MB = MB deriving (Show, Eq, Typeable)
instance RecordType MB DomainName where
    rtToInt       _ = 7
    putRecordData _ = putDomainName
    getRecordData _ = getDomainName

data MG = MG deriving (Show, Eq, Typeable)
instance RecordType MG DomainName where
    rtToInt       _ = 8
    putRecordData _ = putDomainName
    getRecordData _ = getDomainName

data MR = MR deriving (Show, Eq, Typeable)
instance RecordType MR DomainName where
    rtToInt       _ = 9
    putRecordData _ = putDomainName
    getRecordData _ = getDomainName

data NULL = NULL deriving (Show, Eq, Typeable)
instance RecordType NULL BS.ByteString where
    rtToInt                 _ = 10
    putRecordData         _ _ = fail "putRecordData NULL can't be defined"
    getRecordData           _ = fail "getRecordData NULL can't be defined"
    putRecordDataWithLength _ = \ dat ->
                                do P.putWord16be $ fromIntegral $ BS.length dat
                                   P.putByteString dat
    getRecordDataWithLength _ = do len <- U.getWord16be
                                   U.getByteString $ fromIntegral len

data WKS = WKS deriving (Show, Eq, Typeable)
instance RecordType WKS WKSFields where
    rtToInt       _ = 11
    putRecordData _ = \ wks ->
                      do P.putWord32be $ wksAddress wks
                         P.putWord8 $ fromIntegral $ wksProtocol wks
                         P.putLazyByteString $ toBitmap $ wksServices wks
        where
          toBitmap :: IntSet -> LBS.ByteString
          toBitmap is
              = let maxPort   = IS.findMax is
                    range     = [0 .. maxPort]
                    isAvail p = p `IS.member` is
                in
                  runBitPut $ mapM_ putBit $ map isAvail range
    getRecordData _ = fail "getRecordData WKS can't be defined"

    getRecordDataWithLength _
        = do len   <- U.getWord16be
             addr  <- U.getWord32be
             proto <- liftM fromIntegral U.getWord8
             bits  <- U.getByteString $ fromIntegral $ len - 4 - 1
             return WKSFields {
                          wksAddress  = addr
                        , wksProtocol = proto
                        , wksServices = fromBitmap bits
                        }
        where
          fromBitmap :: BS.ByteString -> IntSet
          fromBitmap bs
              = let Right is = runBitGet bs $ worker 0 IS.empty
                in
                  is

          worker :: Int -> IntSet -> BitGet IntSet
          worker pos is
              = do remain <- BG.remaining
                   if remain == 0 then
                       return is
                     else
                       do bit <- getBit
                          if bit then
                              worker (pos + 1) (IS.insert pos is)
                            else
                              worker (pos + 1) is


data PTR = PTR deriving (Show, Eq, Typeable)
instance RecordType PTR DomainName where
    rtToInt       _ = 12
    putRecordData _ = putDomainName
    getRecordData _ = getDomainName

data HINFO = HINFO deriving (Show, Eq, Typeable)
instance RecordType HINFO (BS.ByteString, BS.ByteString) where
    rtToInt       _ = 13
    putRecordData _ = \ (cpu, os) ->
                      do putCharString cpu
                         putCharString os
    getRecordData _ = do cpu <- getCharString
                         os  <- getCharString
                         return (cpu, os)

data MINFO = MINFO deriving (Show, Eq, Typeable)
instance RecordType MINFO (DomainName, DomainName) where
    rtToInt       _ = 14
    putRecordData _ = \ (r, e) ->
                      do putDomainName r
                         putDomainName e
    getRecordData _ = do r <- getDomainName
                         e <- getDomainName
                         return (r, e)

data MX = MX deriving (Show, Eq, Typeable)
instance RecordType MX (Word16, DomainName) where
    rtToInt       _ = 15
    putRecordData _ = \ (pref, exch) ->
                      do P.putWord16be pref
                         putDomainName exch
    getRecordData _ = do pref <- U.getWord16be
                         exch <- getDomainName
                         return (pref, exch)

data TXT = TXT deriving (Show, Eq, Typeable)
instance RecordType TXT [BS.ByteString] where
    rtToInt       _ = 16
    putRecordData _ = mapM_ putCharString
    getRecordData _ = fail "getRecordData TXT can't be defined"

    getRecordDataWithLength _ = U.getWord16be >>= worker [] . fromIntegral
        where
          worker :: [BS.ByteString] -> Int -> Unpacker s [BS.ByteString]
          worker soFar 0 = return (reverse soFar)
          worker soFar n = do str <- getCharString
                              worker (str : soFar) (0 `max` n - 1 - BS.length str)

data AXFR = AXFR deriving (Show, Eq, Typeable)
instance QueryType AXFR where
    qtToInt _ = 252

data MAILB = MAILB deriving (Show, Eq, Typeable)
instance QueryType MAILB where
    qtToInt _ = 253

data MAILA = MAILA deriving (Show, Eq, Typeable)
instance QueryType MAILA where
    qtToInt _ = 254

data ANY = ANY deriving (Show, Eq, Typeable)
instance QueryType ANY where
    qtToInt _ = 255
instance QueryClass ANY where
    qcToInt _ = 255

data IN = IN deriving (Show, Eq, Typeable)
instance RecordClass IN where
    rcToInt _ = 1

data CS = CS deriving (Show, Eq, Typeable)
instance RecordClass CS where
    rcToInt _ = 2

data CH = CH deriving (Show, Eq, Typeable)
instance RecordClass CH where
    rcToInt _ = 3

data HS = HS deriving (Show, Eq, Typeable)
instance RecordClass HS where
    rcToInt _ = 4


instance Binary Message where
    put m = P.liftToBinary M.empty $
            do putBinary $ msgHeader m
               P.putWord16be $ fromIntegral $ length $ msgQuestions m
               P.putWord16be $ fromIntegral $ length $ msgAnswers m
               P.putWord16be $ fromIntegral $ length $ msgAuthorities m
               P.putWord16be $ fromIntegral $ length $ msgAdditionals m
               mapM_ putSomeQ  $ msgQuestions m
               mapM_ putSomeRR $ msgAnswers m
               mapM_ putSomeRR $ msgAuthorities m
               mapM_ putSomeRR $ msgAdditionals m

    get = U.liftToBinary IM.empty $
          do hdr  <- getBinary
             nQ   <- liftM fromIntegral U.getWord16be
             nAns <- liftM fromIntegral U.getWord16be
             nAth <- liftM fromIntegral U.getWord16be
             nAdd <- liftM fromIntegral U.getWord16be
             qs   <- replicateM nQ   getSomeQ
             anss <- replicateM nAns getSomeRR
             aths <- replicateM nAth getSomeRR
             adds <- replicateM nAdd getSomeRR
             return Message {
                          msgHeader      = hdr
                        , msgQuestions   = qs
                        , msgAnswers     = anss
                        , msgAuthorities = aths
                        , msgAdditionals = adds
                        }

instance Binary Header where
    put h = do P'.putWord16be $ hdMessageID h
               P'.putLazyByteString flags
        where
          flags = runBitPut $
                  do putNBits 1 $ fromEnum $ hdMessageType h
                     putNBits 4 $ fromEnum $ hdOpcode h
                     putBit $ hdIsAuthoritativeAnswer h
                     putBit $ hdIsTruncated h
                     putBit $ hdIsRecursionDesired h
                     putBit $ hdIsRecursionAvailable h
                     putNBits 3 (0 :: Int)
                     putNBits 4 $ fromEnum $ hdResponseCode h

    get = do mID   <- G.getWord16be
             flags <- G.getByteString 2
             let Right hd
                     = runBitGet flags $
                       do qr <- liftM (toEnum . fromIntegral) $ getAsWord8 1
                          op <- liftM (toEnum . fromIntegral) $ getAsWord8 4
                          aa <- getBit
                          tc <- getBit
                          rd <- getBit
                          ra <- getBit
                          BG.skip 3
                          rc <- liftM (toEnum . fromIntegral) $ getAsWord8 4
                          return Header {
                                       hdMessageID             = mID
                                     , hdMessageType           = qr
                                     , hdOpcode                = op
                                     , hdIsAuthoritativeAnswer = aa
                                     , hdIsTruncated           = tc
                                     , hdIsRecursionDesired    = rd
                                     , hdIsRecursionAvailable  = ra
                                     , hdResponseCode          = rc
                                     }
             return hd

instance Enum MessageType where
    fromEnum Query    = 0
    fromEnum Response = 1

    toEnum 0 = Query
    toEnum 1 = Response
    toEnum _ = undefined

instance Enum Opcode where
    fromEnum StandardQuery       = 0
    fromEnum InverseQuery        = 1
    fromEnum ServerStatusRequest = 2

    toEnum 0 = StandardQuery
    toEnum 1 = InverseQuery
    toEnum 2 = ServerStatusRequest
    toEnum _ = undefined

instance Enum ResponseCode where
    fromEnum NoError        = 0
    fromEnum FormatError    = 1
    fromEnum ServerFailure  = 2
    fromEnum NameError      = 3
    fromEnum NotImplemented = 4
    fromEnum Refused        = 5

    toEnum 0 = NoError
    toEnum 1 = FormatError
    toEnum 2 = ServerFailure
    toEnum 3 = NameError
    toEnum 4 = NotImplemented
    toEnum 5 = Refused
    toEnum _ = undefined


defaultRTTable :: IntMap SomeRT
defaultRTTable = IM.fromList $ map toPair $
                 [ SomeRT A
                 , SomeRT NS
                 , SomeRT MD
                 , SomeRT MF
                 , SomeRT CNAME
                 , SomeRT SOA
                 , SomeRT MB
                 , SomeRT MG
                 , SomeRT MR
                 , SomeRT NULL
                 , SomeRT WKS
                 , SomeRT PTR
                 , SomeRT HINFO
                 , SomeRT MINFO
                 , SomeRT MX
                 , SomeRT TXT
                 ]
    where
      toPair :: SomeRT -> (Int, SomeRT)
      toPair srt@(SomeRT rt) = (rtToInt rt, srt)

defaultQTTable :: IntMap SomeQT
defaultQTTable = mergeWithRTTable defaultRTTable $ IM.fromList $ map toPair $
                 [ SomeQT AXFR
                 , SomeQT MAILB
                 , SomeQT MAILA
                 , SomeQT ANY
                 ]
    where
      toPair :: SomeQT -> (Int, SomeQT)
      toPair sqt@(SomeQT qt) = (qtToInt qt, sqt)

      mergeWithRTTable :: IntMap SomeRT -> IntMap SomeQT -> IntMap SomeQT
      mergeWithRTTable rts qts
          = IM.union (toQTTable rts) qts

      toQTTable :: IntMap SomeRT -> IntMap SomeQT
      toQTTable = IM.map toSomeQT

      toSomeQT :: SomeRT -> SomeQT
      toSomeQT (SomeRT rt) = SomeQT rt

defaultRCTable :: IntMap SomeRC
defaultRCTable = IM.fromList $ map toPair $
                 [ SomeRC IN
                 , SomeRC CS
                 , SomeRC CH
                 , SomeRC HS
                 ]
    where
      toPair :: SomeRC -> (Int, SomeRC)
      toPair src@(SomeRC rc) = (rcToInt rc, src)

defaultQCTable :: IntMap SomeQC
defaultQCTable = mergeWithRCTable defaultRCTable $ IM.fromList $ map toPair $
                 [ SomeQC ANY
                 ]
    where
      toPair :: SomeQC -> (Int, SomeQC)
      toPair sqc@(SomeQC qc) = (qcToInt qc, sqc)

      mergeWithRCTable :: IntMap SomeRC -> IntMap SomeQC -> IntMap SomeQC
      mergeWithRCTable rcs qcs
          = IM.union (toQCTable rcs) qcs

      toQCTable :: IntMap SomeRC -> IntMap SomeQC
      toQCTable = IM.map toSomeQC

      toSomeQC :: SomeRC -> SomeQC
      toSomeQC (SomeRC rc) = SomeQC rc


wrapQuestion :: (QueryType qt, QueryClass qc) => Question qt qc -> SomeQ
wrapQuestion = SomeQ

wrapRecord :: (RecordType rt dt, RecordClass rc) => ResourceRecord rt rc dt -> SomeRR
wrapRecord = SomeRR