+class (Typeable rr, Show rr, Eq rr) => ResourceRecord rr where
+ rrName :: rr -> DomainName
+ rrType :: rr -> RecordType
+ rrClass :: rr -> RecordClass
+ rrTTL :: rr -> TTL
+ rrPutData :: rr -> Put
+ rrGetData :: DecompTable -> DomainName -> RecordClass -> TTL -> Get (rr, DecompTable)
+ toRR :: rr -> SomeRR
+ fromRR :: SomeRR -> Maybe rr
+
+ toRR rr = SomeRR rr
+ fromRR (SomeRR rr') = cast rr'
+
+putRR :: ResourceRecord rr => rr -> Put
+putRR rr = do putDomainName $ rrName rr
+ put $ rrType rr
+ put $ rrClass rr
+ putWord32be $ rrTTL rr
+
+ let dat = runPut $ rrPutData rr
+ putWord16be $ fromIntegral $ LBS.length dat
+ putLazyByteString dat
+
+getRR :: DecompTable -> Get (SomeRR, DecompTable)
+getRR dt
+ = do (nm, dt') <- getDomainName dt
+ ty <- get
+ cl <- get
+ ttl <- G.getWord32be
+ case ty of
+ CNAME -> do (rr, dt'') <- rrGetData dt' nm cl ttl
+ return (toRR (rr :: CNAME), dt'')
+ HINFO -> do (rr, dt'') <- rrGetData dt' nm cl ttl
+ return (toRR (rr :: HINFO), dt'')
+ AXFR -> onlyForQuestions "AXFR"
+ MAILB -> onlyForQuestions "MAILB"
+ MAILA -> onlyForQuestions "MAILA"
+ AnyType -> onlyForQuestions "ANY"
+ where
+ onlyForQuestions name
+ = fail (name ++ " is only for questions, not an actual resource record.")
+
+data SomeRR = forall rr. ResourceRecord rr => SomeRR rr
+ deriving Typeable
+instance ResourceRecord SomeRR where
+ rrName (SomeRR rr) = rrName rr
+ rrType (SomeRR rr) = rrType rr
+ rrClass (SomeRR rr) = rrClass rr
+ rrTTL (SomeRR rr) = rrTTL rr
+ rrPutData (SomeRR rr) = rrPutData rr
+ rrGetData _ _ _ _ = fail "SomeRR can't directly be constructed."
+ toRR = id
+ fromRR = Just
+instance Eq SomeRR where
+ (SomeRR a) == (SomeRR b) = Just a == cast b
+instance Show SomeRR where
+ show (SomeRR rr) = show rr
+
+type DecompTable = IntMap BS.ByteString
+type TTL = Word32
+
+data CNAME = CNAME' !DomainName !RecordClass !TTL !DomainName
+ deriving (Eq, Show, Typeable)
+instance ResourceRecord CNAME where
+ rrName (CNAME' n _ _ _) = n
+ rrType _ = CNAME
+ rrClass (CNAME' _ c _ _) = c
+ rrTTL (CNAME' _ _ t _) = t
+ rrGetData dt n c t = do (d, dt') <- getDomainName dt
+ return (CNAME' n c t d, dt')
+ rrPutData (CNAME' _ _ _ d) = putDomainName d
+
+data HINFO = HINFO' !DomainName !RecordClass !TTL !BS.ByteString !BS.ByteString
+ deriving (Eq, Show, Typeable)
+instance ResourceRecord HINFO where
+ rrName (HINFO' n _ _ _ _) = n
+ rrType _ = HINFO
+ rrClass (HINFO' _ c _ _ _) = c
+ rrTTL (HINFO' _ _ t _ _) = t
+ rrGetData dt n c t = do cpu <- getCharString
+ os <- getCharString
+ return (HINFO' n c t cpu os, dt)
+ rrPutData (HINFO' _ _ _ c o) = do putCharString c
+ putCharString o
+
+getDomainName :: DecompTable -> Get (DomainName, DecompTable)
+getDomainName = flip worker []
+ where
+ worker :: DecompTable -> [DomainLabel] -> Get ([DomainLabel], DecompTable)
+ worker dt soFar
+ = do (l, dt') <- getDomainLabel dt
+ case BS.null l of
+ True -> return (reverse (l : soFar), dt')
+ False -> worker dt' (l : soFar)
+
+getDomainLabel :: DecompTable -> Get (DomainLabel, DecompTable)
+getDomainLabel dt
+ = do header <- 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 n
+ -> do let Just l = IM.lookup n dt
+ return (l, dt)
+ Length n
+ -> do offset <- liftM fromIntegral bytesRead
+ label <- getByteString n
+ let dt' = IM.insert offset label dt
+ return (label, dt')
+
+getCharString :: Get BS.ByteString
+getCharString = do len <- G.getWord8
+ getByteString (fromIntegral len)
+
+putCharString :: BS.ByteString -> Put
+putCharString = putDomainLabel
+
+data LabelHeader
+ = Offset !Int
+ | Length !Int
+
+putDomainName :: DomainName -> Put
+putDomainName = mapM_ putDomainLabel
+
+putDomainLabel :: DomainLabel -> Put
+putDomainLabel l
+ = do putWord8 $ fromIntegral $ BS.length l
+ P.putByteString l