+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 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
+
+ putResourceRecord :: ResourceRecord rt dt -> Packer CompTable ()
+ putResourceRecord rr
+ = do putDomainName $ rrName rr
+ putRecordType $ rrType rr
+ putBinary $ rrClass rr
+ P.putWord32be $ rrTTL rr
+
+ -- First, write a dummy data length.
+ offset <- bytesWrote
+ P.putWord16be 0
+
+ -- Second, write data.
+ putRecordData (rrType rr) (rrData rr)
+
+ -- Third, rewrite the dummy length to an actual value.
+ offset' <- bytesWrote
+ withOffset offset
+ $ P.putWord16be (fromIntegral (offset' - offset - 2))
+
+ getResourceRecord :: rt -> Unpacker DecompTable (ResourceRecord rt dt)
+ getResourceRecord rt
+ = do name <- getDomainName
+ U.skip 2 -- record type
+ cl <- getBinary
+ ttl <- U.getWord32be
+ U.skip 2 -- data length
+ dat <- getRecordData rt
+ return $ ResourceRecord {
+ rrName = name
+ , rrType = rt
+ , rrClass = cl
+ , 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
+
+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
+ Nothing
+ -> fail ("Unknown resource record type: " ++ show n)
+ Just srt
+ -> return srt
+
+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 CNAME = CNAME deriving (Show, Eq, Typeable)
+instance RecordType CNAME DomainName where
+ rtToInt _ = 5
+ 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)
+
+
+{-