module DNS.Type (question, rquestion,
putLine, enc, Bufi, Data,
Question(Q), MayIO,
RR(RR), RClass, RType,
Name, satisfies, Zone(..), MayIOSt,
Packet(..), converge, WState, PSt,
errorPacket, emptyPacket, hashQuestion
) where
import Data.Char
import Data.Int (Int32)
import Data.Bits(shiftR)
import Data.Word
import Foreign.Ptr
import Control.Monad.Error
import Control.Monad.State
import Data.Array.Unboxed
type MayIO = ErrorT String IO
type MayIOSt s = StateT s MayIO
type WState = ((), Bufi, Ptr Word8)
type PSt = StateT (Ptr Word8) IO
putLine :: String -> MayIO ()
putLine s = liftIO $ putStrLn s
type Data = UArray Int Word8
data Question = Q !Name !QType !QClass
instance Eq Question where
(==) (Q an at ac) (Q bn bt _) = an == bn && at `teq` bt && ac `teq` bt
teq :: Word16 -> Word16 -> Bool
teq 255 _ = True
teq _ 255 = True
teq x y = x == y
satisfies :: Question -> RR -> Bool
satisfies (Q n t c) (RR rn rt rc _ _) = n == rn && (rt == 5 || t == 255 || t == rt) && c `teq` rc
type QType = Word16
type QClass= Word16
type QId = Word16
type Bufi = (Ptr Word8, Int)
question :: String -> QType -> QClass -> Question
question a b c = Q (enc a) b c
rquestion a b c = Q a b c
hashQuestion :: Question -> Int32
hashQuestion (Q n t _) = fromIntegral $ fromEnum t + foldl fun 0 lst
where lst = take 10 $ drop 4 $ elems n
fun a e = fromEnum e + (a `shiftR` 7)
instance Show Question where
show (Q qs qt qc) = "Question: '"++qd qs++"' type="++show qt++" class="++show qc
enc :: String -> UArray Int Word8
enc s = let lst = enc' s in listArray (0,length lst 1) lst
enc' s = concatMap (\p -> fromIntegral (length p) : map (fromIntegral . ord) p) $ reverse splitted
where ein ("",a) '.' = ("",a)
ein (c,a) '.' = ("",reverse c : a)
ein (c,a) ch = (ch:c,a)
norm l@("":_) = l
norm lst = "":lst
splitted = let (t,r) = foldl ein ("",[]) s in norm $ reverse t : r
qd = qd' . elems
qd' :: [Word8] -> String
qd' [] = ""
qd' (n:ns) = let h = map (chr . fromEnum) $ take (fromEnum n) ns
t = drop (fromEnum n) ns
in if length t <= 1 then h else h ++ '.':qd' t
type RType = Word16
type RClass= Word16
data RR = RR Name RType RClass Word32 Data
instance Show RR where
show (RR n t c ts d) = unwords ["RR",qd n,show t,show c,show ts,show d]
data Zone = Zone Name [RR] deriving(Show)
type Name = UArray Int Word8
data Packet = Packet { idPQ :: !Word16,
hePQ :: !Word16,
qsPQ :: ![Question],
rsPQ :: ![RR],
nsPQ :: ![RR],
asPQ :: ![RR]
} deriving(Show)
emptyPacket = Packet 0 0 [] [] [] []
errorPacket = emptyPacket { hePQ = 33155 }
related :: Question -> RR -> RR -> Bool
related (Q _ qt qc) (RR _ 5 _ _ ca) (RR rn rt rc _ _) = elems ca == elems rn && qt `teq` rt && qc `teq` rc
related _ _ _ = False
converge :: Word16 -> Question -> Packet -> Packet
converge id q p = let rrs = rsPQ p ++ asPQ p
sat = filter (satisfies q) rrs
in Packet id (hePQ p) [q] rrs [] []