AAAA support

[haskell-dns.git] / Network / DNS / Message.hs

diff --git a/Network/DNS/Message.hs b/Network/DNS/Message.hs
index ab1a15426430bb9b7d559561562a1e5fc4b35af8..db5016096df79dc83788770b21de2aa014d60f1e 100644 (file)
--- a/Network/DNS/Message.hs
+++ b/Network/DNS/Message.hs
@@ -10,16 +10,20 @@ module Network.DNS.Message
     , DomainName
     , DomainLabel
     , TTL
     , DomainName
     , DomainLabel
     , TTL

+
+    , QueryType
+    , QueryClass

     , RecordType
     , RecordType

-    , RecordClass(..)
+    , RecordClass

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

+    , WKSFields(..)

 
 

-    , SomeQT
-    , SomeRR
-    , SomeRT
+    , SomeQ(..)
+    , SomeRR(..)

 
     , A(..)
 
     , A(..)

+    , AAAA(..)

     , NS(..)
     , MD(..)
     , MF(..)
     , NS(..)
     , MD(..)
     , MF(..)


@@ -29,15 +33,32 @@ module Network.DNS.Message
     , MG(..)
     , MR(..)
     , NULL(..)
     , MG(..)
     , MR(..)
     , NULL(..)

+    , WKS(..)

     , PTR(..)
     , HINFO(..)
     , MINFO(..)
     , MX(..)
     , TXT(..)
 
     , PTR(..)
     , HINFO(..)
     , MINFO(..)
     , MX(..)
     , TXT(..)
 

+    , AXFR(..)
+    , MAILB(..)
+    , MAILA(..)
+    , ANY(..)
+
+    , IN(..)
+    , CS(..)
+    , CH(..)
+    , HS(..)
+

     , mkDomainName
     , mkDomainName

-    , wrapQueryType
-    , wrapRecordType
+    , rootName
+    , isRootName
+    , consLabel
+    , unconsLabel
+    , nameToLabels
+    , isZoneOf
+
+    , wrapQuestion

     , wrapRecord
     )
     where
     , wrapRecord
     )
     where


@@ -51,9 +72,14 @@ 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           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.String

 import           Data.Typeable
 import qualified Data.IntMap as IM
 import           Data.IntMap (IntMap)
 import           Data.Typeable
 import qualified Data.IntMap as IM
 import           Data.IntMap (IntMap)

+import qualified Data.IntSet as IS
+import           Data.IntSet (IntSet)
+import           Data.List

 import qualified Data.Map as M
 import           Data.Map (Map)
 import           Data.Word
 import qualified Data.Map as M
 import           Data.Map (Map)
 import           Data.Word


@@ -65,7 +91,7 @@ import           Network.Socket
 data Message
     = Message {
         msgHeader      :: !Header
 data Message
     = Message {
         msgHeader      :: !Header

-      , msgQuestions   :: ![Question]
+      , msgQuestions   :: ![SomeQ]

       , msgAnswers     :: ![SomeRR]
       , msgAuthorities :: ![SomeRR]
       , msgAdditionals :: ![SomeRR]
       , msgAnswers     :: ![SomeRR]
       , msgAuthorities :: ![SomeRR]
       , msgAdditionals :: ![SomeRR]


@@ -113,36 +139,90 @@ data ResponseCode
     | Refused
     deriving (Show, Eq)
 
     | Refused
     deriving (Show, Eq)
 

-data Question
+data (QueryType qt, QueryClass qc) => Question qt qc

     = Question {
         qName  :: !DomainName
     = Question {
         qName  :: !DomainName

-      , qType  :: !SomeQT
-      , qClass :: !RecordClass
+      , qType  :: !qt
+      , qClass :: !qc

       }
       }

-    deriving (Show, Eq)
+    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

 
 

-type SomeQT = SomeRT
+data SomeQT = forall qt. QueryType qt => SomeQT qt

 
 

-putQ :: Question -> Packer CompTable ()
-putQ q
+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
     = do putDomainName $ qName q

-         putSomeRT $ qType q
-         putBinary $ qClass 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)

 
 

-getQ :: Unpacker DecompTable Question
-getQ = do nm <- getDomainName
-          ty <- getSomeRT
-          cl <- getBinary
-          return Question {
-                       qName  = nm
-                     , qType  = ty
-                     , qClass = cl
-                     }
+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
 
 
 
 newtype DomainName  = DN [DomainLabel] deriving (Eq, Show, Ord, Typeable)
 type DomainLabel    = BS.ByteString
 

+instance IsString DomainName where
+    fromString = mkDomainName
+

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


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

+nameToLabels :: DomainName -> [DomainLabel]
+nameToLabels (DN xs) = xs
+
+isZoneOf :: DomainName -> DomainName -> Bool
+isZoneOf (DN a) (DN b) = a `isSuffixOf` b
+

 mkDomainName :: String -> DomainName
 mkDomainName = DN . mkLabels [] . notEmpty
     where
 mkDomainName :: String -> DomainName
 mkDomainName = DN . mkLabels [] . notEmpty
     where


@@ -170,27 +256,26 @@ mkDomainName = DN . mkLabels [] . notEmpty
                                 -> mkLabels (C8.pack l : soFar) rest
                             _   -> error ("Illegal domain name: " ++ xs)
 
                                 -> mkLabels (C8.pack l : soFar) rest
                             _   -> error ("Illegal domain name: " ++ xs)
 

-data RecordClass
-    = IN
-    | CS -- Obsolete
-    | CH
-    | HS
-    | AnyClass -- Only for queries
-    deriving (Show, Eq)

 
 

+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 => ResourceRecord rt dt
+
+data (RecordType rt dt, RecordClass rc) => ResourceRecord rt rc dt

     = ResourceRecord {
         rrName  :: !DomainName
       , rrType  :: !rt
     = ResourceRecord {
         rrName  :: !DomainName
       , rrType  :: !rt

-      , rrClass :: !RecordClass
+      , rrClass :: !rc

       , rrTTL   :: !TTL
       , rrData  :: !dt
       }
     deriving (Show, Eq, Typeable)
 
 
       , rrTTL   :: !TTL
       , rrData  :: !dt
       }
     deriving (Show, Eq, Typeable)
 
 

-data SomeRR = forall rt dt. RecordType rt dt => SomeRR (ResourceRecord rt dt)
+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 Show SomeRR where
     show (SomeRR rr) = show rr


@@ -203,12 +288,14 @@ putSomeRR :: SomeRR -> Packer CompTable ()
 putSomeRR (SomeRR rr) = putResourceRecord rr
 
 getSomeRR :: Unpacker DecompTable SomeRR
 putSomeRR (SomeRR rr) = putResourceRecord rr
 
 getSomeRR :: Unpacker DecompTable SomeRR

-getSomeRR = do srt <- U.lookAhead $
-                      do getDomainName -- skip
-                         getSomeRT
-               case srt of
-                 SomeRT rt
-                     -> getResourceRecord rt >>= return . 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 CompTable   = Map DomainName Int
 type DecompTable = IntMap DomainName


@@ -299,6 +386,24 @@ putDomainName name
                        else
                          putDomainName rest
 
                        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
 
 class (Show rt, Show dt, Eq rt, Eq dt, Typeable rt, Typeable dt) => RecordType rt dt | rt -> dt where
     rtToInt       :: rt -> Int


@@ -319,15 +424,20 @@ class (Show rt, Show dt, Eq rt, Eq dt, Typeable rt, Typeable dt) => RecordType r
 
              -- Third, rewrite the dummy length to an actual value.
              offset' <- bytesWrote
 
              -- Third, rewrite the dummy length to an actual value.
              offset' <- bytesWrote

-             withOffset offset
-                 $ P.putWord16be (fromIntegral (offset' - offset - 2))
-
-    putResourceRecord :: ResourceRecord rt dt -> Packer CompTable ()
+             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
     putResourceRecord rr

-        = do putDomainName $ rrName  rr
-             putRecordType $ rrType  rr
-             putBinary     $ rrClass rr
-             P.putWord32be $ rrTTL   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
              putRecordDataWithLength (rrType rr) (rrData rr)
 
     getRecordDataWithLength :: rt -> Unpacker DecompTable dt


@@ -344,21 +454,22 @@ class (Show rt, Show dt, Eq rt, Eq dt, Typeable rt, Typeable dt) => RecordType r
 
              return dat
 
 
              return dat
 

-    getResourceRecord :: rt -> Unpacker DecompTable (ResourceRecord rt dt)
-    getResourceRecord rt
+    getResourceRecord :: RecordClass rc => rt -> rc -> Unpacker DecompTable (ResourceRecord rt rc dt)
+    getResourceRecord rt rc

         = do name     <- getDomainName
              U.skip 2 -- record type
         = do name     <- getDomainName
              U.skip 2 -- record type

-             cl       <- getBinary
+             U.skip 2 -- record class

              ttl      <- U.getWord32be
              dat      <- getRecordDataWithLength rt
              return $ ResourceRecord {
                           rrName  = name
                         , rrType  = rt
              ttl      <- U.getWord32be
              dat      <- getRecordDataWithLength rt
              return $ ResourceRecord {
                           rrName  = name
                         , rrType  = rt

-                        , rrClass = cl
+                        , rrClass = rc

                         , rrTTL   = ttl
                         , rrData  = dat
                         }
 
                         , rrTTL   = ttl
                         , rrData  = dat
                         }
 

+

 data SomeRT = forall rt dt. RecordType rt dt => SomeRT rt
 
 instance Show SomeRT where
 data SomeRT = forall rt dt. RecordType rt dt => SomeRT rt
 
 instance Show SomeRT where


@@ -367,9 +478,6 @@ instance Show SomeRT where
 instance Eq SomeRT where
     (SomeRT a) == (SomeRT b) = Just a == cast b
 
 instance Eq SomeRT where
     (SomeRT a) == (SomeRT b) = Just a == cast b
 

-putSomeRT :: SomeRT -> Packer s ()
-putSomeRT (SomeRT rt) = putRecordType rt
-

 getSomeRT :: Unpacker s SomeRT
 getSomeRT = do n <- liftM fromIntegral U.getWord16be
                case IM.lookup n defaultRTTable of
 getSomeRT :: Unpacker s SomeRT
 getSomeRT = do n <- liftM fromIntegral U.getWord16be
                case IM.lookup n defaultRTTable of


@@ -378,6 +486,23 @@ getSomeRT = do n <- liftM fromIntegral U.getWord16be
                  Just srt
                      -> return srt
 
                  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
 data SOAFields
     = SOAFields {
         soaMasterNameServer   :: !DomainName


@@ -390,12 +515,35 @@ data SOAFields
       }
     deriving (Show, Eq, Typeable)
 
       }
     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 A = A deriving (Show, Eq, Typeable)
 instance RecordType A HostAddress where
     rtToInt       _ = 1
     putRecordData _ = P.putWord32be
     getRecordData _ = U.getWord32be
 

+data AAAA = AAAA deriving (Show, Eq, Typeable)
+instance RecordType AAAA HostAddress6 where
+    rtToInt       _ = 28
+    putRecordData _ = \ (a, b, c, d) ->
+                      do P.putWord32be a
+                         P.putWord32be b
+                         P.putWord32be c
+                         P.putWord32be d
+    getRecordData _ = do a <- U.getWord32be
+                         b <- U.getWord32be
+                         c <- U.getWord32be
+                         d <- U.getWord32be
+                         return (a, b, c, d)
+

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


@@ -477,6 +625,53 @@ instance RecordType NULL BS.ByteString where
     getRecordDataWithLength _ = do len <- U.getWord16be
                                    U.getByteString $ fromIntegral len
 
     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
 data PTR = PTR deriving (Show, Eq, Typeable)
 instance RecordType PTR DomainName where
     rtToInt       _ = 12


@@ -526,32 +721,40 @@ instance RecordType TXT [BS.ByteString] where
           worker soFar n = do str <- getCharString
                               worker (str : soFar) (0 `max` n - 1 - BS.length str)
 
           worker soFar n = do str <- getCharString
                               worker (str : soFar) (0 `max` n - 1 - BS.length str)
 

-{-
-data RecordType
-    = A
-    | NS
-    | MD
-    | MF
-    | CNAME
-    | SOA
-    | MB
-    | MG
-    | MR
-    | NULL
-    | WKS
-    | PTR
-    | HINFO
-    | MINFO
-    | MX
-    | TXT
-
-    -- Only for queries:
-    | AXFR
-    | MAILB -- Obsolete
-    | MAILA -- Obsolete
-    | AnyType
-    deriving (Show, Eq)
--}
+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 $
 
 instance Binary Message where
     put m = P.liftToBinary M.empty $


@@ -560,7 +763,7 @@ instance Binary Message where
                P.putWord16be $ fromIntegral $ length $ msgAnswers m
                P.putWord16be $ fromIntegral $ length $ msgAuthorities m
                P.putWord16be $ fromIntegral $ length $ msgAdditionals m
                P.putWord16be $ fromIntegral $ length $ msgAnswers m
                P.putWord16be $ fromIntegral $ length $ msgAuthorities m
                P.putWord16be $ fromIntegral $ length $ msgAdditionals m

-               mapM_ putQ      $ msgQuestions m
+               mapM_ putSomeQ  $ msgQuestions m

                mapM_ putSomeRR $ msgAnswers m
                mapM_ putSomeRR $ msgAuthorities m
                mapM_ putSomeRR $ msgAdditionals m
                mapM_ putSomeRR $ msgAnswers m
                mapM_ putSomeRR $ msgAuthorities m
                mapM_ putSomeRR $ msgAdditionals m


@@ -571,7 +774,7 @@ instance Binary Message where
              nAns <- liftM fromIntegral U.getWord16be
              nAth <- liftM fromIntegral U.getWord16be
              nAdd <- liftM fromIntegral U.getWord16be
              nAns <- liftM fromIntegral U.getWord16be
              nAth <- liftM fromIntegral U.getWord16be
              nAdd <- liftM fromIntegral U.getWord16be

-             qs   <- replicateM nQ   getQ
+             qs   <- replicateM nQ   getSomeQ

              anss <- replicateM nAns getSomeRR
              aths <- replicateM nAth getSomeRR
              adds <- replicateM nAdd getSomeRR
              anss <- replicateM nAns getSomeRR
              aths <- replicateM nAth getSomeRR
              adds <- replicateM nAdd getSomeRR


@@ -655,66 +858,84 @@ instance Enum ResponseCode where
     toEnum 5 = Refused
     toEnum _ = undefined
 
     toEnum 5 = Refused
     toEnum _ = undefined
 

-{-
-instance Enum RecordType where
-    fromEnum A       = 1 /
-    fromEnum NS      = 2 /
-    fromEnum MD      = 3 /
-    fromEnum MF      = 4 /
-    fromEnum CNAME   = 5 /
-    fromEnum SOA     = 6 /
-    fromEnum MB      = 7 /
-    fromEnum MG      = 8 /
-    fromEnum MR      = 9 /
-    fromEnum NULL    = 10 /
-    fromEnum WKS     = 11
-    fromEnum PTR     = 12 /
-    fromEnum HINFO   = 13 /
-    fromEnum MINFO   = 14 /
-    fromEnum MX      = 15 /
-    fromEnum TXT     = 16 /
-    fromEnum AXFR    = 252
-    fromEnum MAILB   = 253
-    fromEnum MAILA   = 254
-    fromEnum AnyType = 255
--}
-
-instance Enum RecordClass where
-    fromEnum IN       = 1
-    fromEnum CS       = 2
-    fromEnum CH       = 3
-    fromEnum HS       = 4
-    fromEnum AnyClass = 255
-
-    toEnum 1   = IN
-    toEnum 2   = CS
-    toEnum 3   = CH
-    toEnum 4   = HS
-    toEnum 255 = AnyClass
-    toEnum _   = undefined
-
-instance Binary RecordClass where
-    get = liftM (toEnum . fromIntegral) G.getWord16be
-    put = P'.putWord16be . fromIntegral . fromEnum
-

 
 defaultRTTable :: IntMap SomeRT
 defaultRTTable = IM.fromList $ map toPair $
 
 defaultRTTable :: IntMap SomeRT
 defaultRTTable = IM.fromList $ map toPair $

-                 [ wrapRecordType A
-                 , wrapRecordType NS
-                 , wrapRecordType CNAME
-                 , wrapRecordType HINFO
+                 [ SomeRT A
+                 , SomeRT AAAA
+                 , 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)
 
                  ]
     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

 
 

-wrapQueryType :: RecordType rt dt => rt -> SomeQT
-wrapQueryType = SomeRT

 
 

-wrapRecordType :: RecordType rt dt => rt -> SomeRT
-wrapRecordType = SomeRT
+wrapQuestion :: (QueryType qt, QueryClass qc) => Question qt qc -> SomeQ
+wrapQuestion = SomeQ

 
 

-wrapRecord :: RecordType rt dt => ResourceRecord rt dt -> SomeRR
-wrapRecord = SomeRR
\ No newline at end of file
+wrapRecord :: (RecordType rt dt, RecordClass rc) => ResourceRecord rt rc dt -> SomeRR
+wrapRecord = SomeRR