, DomainName
, DomainLabel
, TTL
+
+ , QueryType
+ , QueryClass
, RecordType
- , RecordClass(..)
+ , RecordClass
+
+ , SOAFields(..)
+ , WKSFields(..)
- , SomeQT
- , SomeRR
- , SomeRT
+ , 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
- , wrapQueryType
- , wrapRecordType
+ , mkDN
+ , rootName
+ , isRootName
+ , consLabel
+ , unconsLabel
+ , nameToLabels
+ , isZoneOf
+
+ , wrapQuestion
, wrapRecord
)
where
import Data.Binary
import Data.Binary.BitPut as BP
import Data.Binary.Get as G
-import Data.Binary.Put as P
+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.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 Network.DNS.Packer as P
+import Network.DNS.Unpacker as U
import Network.Socket
-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'
-
-
data Message
= Message {
msgHeader :: !Header
- , msgQuestions :: ![Question]
+ , msgQuestions :: ![SomeQ]
, msgAnswers :: ![SomeRR]
, msgAuthorities :: ![SomeRR]
, msgAdditionals :: ![SomeRR]
| Refused
deriving (Show, Eq)
-data Question
+data (QueryType qt, QueryClass qc) => Question qt qc
= 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
+
+data SomeQT = forall qt. QueryType qt => SomeQT qt
-type SomeQT = SomeRT
+instance Show SomeQT where
+ show (SomeQT qt) = show qt
-putQ :: Question -> Put
-putQ q
+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
- 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')
-
-newtype DomainName = DN [DomainLabel] deriving (Eq, Show, Typeable)
-type DomainLabel = BS.ByteString
+ 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)
-nameToLabels :: DomainName -> [DomainLabel]
-nameToLabels (DN ls) = ls
-labelsToName :: [DomainLabel] -> DomainName
-labelsToName = DN
+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)
+
+nameToLabels :: DomainName -> [DomainLabel]
+nameToLabels (DN xs) = xs
+
+isZoneOf :: DomainName -> DomainName -> Bool
+isZoneOf (DN a) (DN b) = a `isSuffixOf` b
+
mkDomainName :: String -> DomainName
-mkDomainName = labelsToName . mkLabels [] . notEmpty
+mkDomainName = DN . mkLabels [] . notEmpty
where
notEmpty :: String -> String
notEmpty xs = assert (not $ null xs) 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)
+mkDN :: String -> DomainName
+mkDN = mkDomainName
+
+
+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
- , rrClass :: !RecordClass
+ , rrClass :: !rc
, rrTTL :: !TTL
, rrData :: !dt
}
deriving (Show, Eq, Typeable)
-putRR :: forall rt dt. RecordType rt dt => ResourceRecord rt dt -> Put
-putRR rr = do putDomainName $ rrName rr
- putRecordType $ rrType rr
- put $ rrClass rr
- putWord32be $ rrTTL rr
-
- let dat = runPut $
- putRecordData (undefined :: rt) (rrData rr)
- putWord16be $ fromIntegral $ LBS.length dat
- 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)
+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
(SomeRR a) == (SomeRR b) = Just a == cast b
-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')
+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
+type TTL = Word32
-getDomainName :: DecompTable -> Get (DomainName, DecompTable)
+getDomainName :: Unpacker DecompTable DomainName
getDomainName = worker
where
- worker :: DecompTable -> Get (DomainName, DecompTable)
- worker dt
- = do offset <- liftM fromIntegral bytesRead
+ worker :: Unpacker DecompTable DomainName
+ worker
+ = do offset <- U.bytesRead
hdr <- getLabelHeader
case hdr of
Offset n
- -> case IM.lookup n dt of
- Just name
- -> return (name, dt)
- Nothing
- -> fail ("Illegal offset of label pointer: " ++ show (n, dt))
+ -> 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, dt)
+ -> return rootName
Length n
- -> do label <- getByteString n
- (rest, dt') <- worker dt
+ -> do label <- U.getByteString n
+ rest <- worker
let name = consLabel label rest
- dt'' = IM.insert offset name dt'
- return (name, dt'')
+ U.modifyState $ IM.insert offset name
+ return name
- getLabelHeader :: Get LabelHeader
+ getLabelHeader :: Unpacker s LabelHeader
getLabelHeader
- = do header <- lookAhead $ getByteString 1
+ = do header <- U.lookAhead $ U.getByteString 1
let Right h
= runBitGet header $
do a <- getBit
_ -> fail "Illegal label header"
case h of
Offset _
- -> do header' <- getByteString 2 -- Pointers have 2 octets.
+ -> do header' <- U.getByteString 2 -- Pointers have 2 octets.
let Right h'
= runBitGet header' $
do BG.skip 2
return $ Offset n
return h'
len@(Length _)
- -> do G.skip 1
+ -> do U.skip 1
return len
-getCharString :: Get BS.ByteString
-getCharString = do len <- G.getWord8
- getByteString (fromIntegral len)
+getCharString :: Unpacker s BS.ByteString
+getCharString = do len <- U.getWord8
+ U.getByteString (fromIntegral len)
-putCharString :: BS.ByteString -> Put
-putCharString = putDomainLabel
+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 -> Put
-putDomainName = mapM_ putDomainLabel . nameToLabels
+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
-putDomainLabel :: DomainLabel -> Put
-putDomainLabel l
- = do putWord8 $ fromIntegral $ BS.length l
- P.putByteString l
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)
+ 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
+ }
- putRecordType = putWord16be . fromIntegral . rtToInt
data SomeRT = forall rt dt. RecordType rt dt => SomeRT rt
instance Eq SomeRT where
(SomeRT a) == (SomeRT b) = Just a == cast b
-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 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 _ = putWord32be
- getRecordData _ = \ dt ->
- do addr <- G.getWord32be
- return (addr, dt)
+ putRecordData _ = P.putWord32be
+ getRecordData _ = U.getWord32be
data NS = NS deriving (Show, Eq, Typeable)
instance RecordType NS DomainName where
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 _ dt = do cpu <- getCharString
- os <- getCharString
- return ((cpu, os), dt)
-
-
-{-
-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)
--}
+ 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 = do put $ msgHeader m
- putWord16be $ fromIntegral $ length $ msgQuestions m
- putWord16be $ fromIntegral $ length $ msgAnswers m
- putWord16be $ fromIntegral $ length $ msgAuthorities m
- putWord16be $ fromIntegral $ length $ msgAdditionals m
- mapM_ putQ $ msgQuestions m
+ 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 = 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 = 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
}
instance Binary Header where
- put h = do putWord16be $ hdMessageID h
- putLazyByteString flags
+ put h = do P'.putWord16be $ hdMessageID h
+ P'.putLazyByteString flags
where
flags = runBitPut $
do putNBits 1 $ fromEnum $ hdMessageType h
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
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
-
- toEnum 1 = A
- toEnum 2 = NS
- toEnum 3 = MD
- toEnum 4 = MF
- toEnum 5 = CNAME
- toEnum 6 = SOA
- toEnum 7 = MB
- toEnum 8 = MG
- toEnum 9 = MR
- toEnum 10 = NULL
- toEnum 11 = WKS
- toEnum 12 = PTR
- toEnum 13 = HINFO
- toEnum 14 = MINFO
- toEnum 15 = MX
- toEnum 16 = TXT
- toEnum 252 = AXFR
- toEnum 253 = MAILB
- toEnum 254 = MAILA
- toEnum 255 = AnyType
- toEnum _ = undefined
--}
-
-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 = putWord16be . fromIntegral . fromEnum
-
defaultRTTable :: IntMap SomeRT
defaultRTTable = IM.fromList $ map toPair $
- [ wrapRecordType A
- , wrapRecordType NS
- , wrapRecordType CNAME
- , wrapRecordType HINFO
+ [ 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
-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
projects / haskell-dns.git / blobdiff