, RecordType
, RecordClass(..)
- , SomeRR(..)
- , SomeRT(..)
+ , SomeQT
+ , SomeRR
+ , SomeRT
+ , A(..)
+ , NS(..)
, CNAME(..)
, HINFO(..)
- , mkQueryType
, mkDomainName
+ , wrapQueryType
+ , wrapRecordType
+ , wrapRecord
)
where
import qualified Data.IntMap as IM
import Data.IntMap (IntMap)
import Data.Word
-
-
-replicateM' :: Monad m => Int -> (a -> m (b, a)) -> a -> m ([b], a)
-replicateM' = worker []
- where
- worker :: Monad m => [b] -> Int -> (a -> m (b, a)) -> a -> m ([b], a)
- worker soFar 0 _ a = return (reverse soFar, a)
- worker soFar n f a = do (b, a') <- f a
- worker (b : soFar) (n - 1) f a'
+import Network.DNS.Unpacker as U
+import Network.Socket
data Message
type SomeQT = SomeRT
-mkQueryType :: RecordType rt dt => rt -> SomeQT
-mkQueryType = SomeRT
-
putQ :: Question -> Put
putQ q
= do putDomainName $ qName q
putSomeRT $ qType q
put $ qClass q
-getQ :: DecompTable -> Get (Question, DecompTable)
-getQ dt
- = do (nm, dt') <- getDomainName dt
- ty <- getSomeRT
- cl <- get
- let q = Question {
- qName = nm
- , qType = ty
- , qClass = cl
- }
- return (q, dt')
+getQ :: Unpacker DecompTable Question
+getQ = do nm <- getDomainName
+ ty <- getSomeRT
+ cl <- getBinary
+ return Question {
+ qName = nm
+ , qType = ty
+ , qClass = cl
+ }
+
newtype DomainName = DN [DomainLabel] deriving (Eq, Show, Typeable)
type DomainLabel = BS.ByteString
labelsToName :: [DomainLabel] -> DomainName
labelsToName = DN
+rootName :: DomainName
+rootName = DN [BS.empty]
+
+consLabel :: DomainLabel -> DomainName -> DomainName
+consLabel x (DN ys) = DN (x:ys)
+
mkDomainName :: String -> DomainName
mkDomainName = labelsToName . mkLabels [] . notEmpty
where
putLazyByteString dat
-getRR :: forall rt dt. RecordType rt dt => DecompTable -> rt -> Get (ResourceRecord rt dt, DecompTable)
-getRR dt rt
- = do (nm, dt1) <- getDomainName dt
- G.skip 2 -- record type
- cl <- get
- ttl <- G.getWord32be
- G.skip 2 -- data length
- (dat, dt2) <- getRecordData (undefined :: rt) dt1
-
- let rr = ResourceRecord {
- rrName = nm
- , rrType = rt
- , rrClass = cl
- , rrTTL = ttl
- , rrData = dat
- }
- return (rr, dt2)
-
-
data SomeRR = forall rt dt. RecordType rt dt => SomeRR (ResourceRecord rt dt)
instance Show SomeRR where
putSomeRR :: SomeRR -> Put
putSomeRR (SomeRR rr) = putRR rr
-getSomeRR :: DecompTable -> Get (SomeRR, DecompTable)
-getSomeRR dt
- = do srt <- lookAhead $
- do getDomainName dt -- skip
- getSomeRT
- case srt of
- SomeRT rt -> getRR dt rt >>= \ (rr, dt') -> return (SomeRR rr, dt')
-
+getSomeRR :: Unpacker DecompTable SomeRR
+getSomeRR = do srt <- U.lookAhead $
+ do getDomainName -- skip
+ getSomeRT
+ case srt of
+ SomeRT rt
+ -> getResourceRecord rt >>= return . SomeRR
-type DecompTable = IntMap BS.ByteString
+type DecompTable = IntMap DomainName
type TTL = Word32
-getDomainName :: DecompTable -> Get (DomainName, DecompTable)
-getDomainName = flip worker []
+getDomainName :: Unpacker DecompTable DomainName
+getDomainName = worker
where
- worker :: DecompTable -> [DomainLabel] -> Get (DomainName, DecompTable)
- worker dt soFar
- = do (l, dt') <- getDomainLabel dt
- case BS.null l of
- True -> return (labelsToName (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)
+ worker :: Unpacker DecompTable DomainName
+ worker
+ = do offset <- U.bytesRead
+ hdr <- getLabelHeader
+ case hdr of
+ Offset n
+ -> do dt <- 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
+ 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 -> Put
putCharString = putDomainLabel
class (Show rt, Show dt, Eq rt, Eq dt, Typeable rt, Typeable dt) => RecordType rt dt | rt -> dt where
rtToInt :: rt -> Int
- putRecordType :: rt -> Put
putRecordData :: rt -> dt -> Put
- getRecordData :: rt -> DecompTable -> Get (dt, DecompTable)
+ getRecordData :: rt -> Unpacker DecompTable dt
+ putRecordType :: rt -> Put
putRecordType = putWord16be . fromIntegral . rtToInt
+ 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
putSomeRT :: SomeRT -> Put
putSomeRT (SomeRT rt) = putRecordType rt
-getSomeRT :: Get SomeRT
-getSomeRT = do n <- liftM fromIntegral G.getWord16be
+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 _ = 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
rtToInt _ = 13
putRecordData _ (cpu, os) = do putCharString cpu
putCharString os
- getRecordData _ dt = do cpu <- getCharString
+ getRecordData _ = do cpu <- getCharString
os <- getCharString
- return ((cpu, os), dt)
+ return (cpu, os)
+
{-
data RecordType
mapM_ putSomeRR $ msgAuthorities m
mapM_ putSomeRR $ msgAdditionals m
- get = do hdr <- get
- nQ <- liftM fromIntegral G.getWord16be
- nAns <- liftM fromIntegral G.getWord16be
- nAth <- liftM fromIntegral G.getWord16be
- nAdd <- liftM fromIntegral G.getWord16be
- (qs , dt1) <- replicateM' nQ getQ IM.empty
- (anss, dt2) <- replicateM' nAns getSomeRR dt1
- (aths, dt3) <- replicateM' nAth getSomeRR dt2
- (adds, _ ) <- replicateM' nAdd getSomeRR dt3
+ get = 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 getQ
+ anss <- replicateM nAns getSomeRR
+ aths <- replicateM nAth getSomeRR
+ adds <- replicateM nAdd getSomeRR
return Message {
msgHeader = hdr
, msgQuestions = qs
putNBits 4 $ fromEnum $ hdResponseCode h
get = do mID <- G.getWord16be
- flags <- getByteString 2
+ flags <- G.getByteString 2
let Right hd
= runBitGet flags $
do qr <- liftM (toEnum . fromIntegral) $ getAsWord8 1
defaultRTTable :: IntMap SomeRT
defaultRTTable = IM.fromList $ map toPair $
- [ SomeRT CNAME
+ [ wrapRecordType A
+ , wrapRecordType NS
+ , wrapRecordType CNAME
+ , wrapRecordType HINFO
]
where
toPair :: SomeRT -> (Int, SomeRT)
toPair srt@(SomeRT rt) = (rtToInt rt, srt)
+
+
+wrapQueryType :: RecordType rt dt => rt -> SomeQT
+wrapQueryType = SomeRT
+
+wrapRecordType :: RecordType rt dt => rt -> SomeRT
+wrapRecordType = SomeRT
+
+wrapRecord :: RecordType rt dt => ResourceRecord rt dt -> SomeRR
+wrapRecord = SomeRR
\ No newline at end of file