module ADNS.Base where
import Control.Exception ( assert, bracket )
import Network ( HostName )
import Network.Socket ( HostAddress )
import Foreign
import Foreign.C
import ADNS.Endian
data OpaqueState
type AdnsState = Ptr OpaqueState
data OpaqueQuery
type Query = Ptr OpaqueQuery
data InitFlag
= NoEnv
| NoErrPrint
| NoServerWarn
| Debug
| LogPid
| NoAutoSys
| Eintr
| NoSigPipe
| CheckC_EntEx
| CheckC_Freq
deriving (Eq, Bounded, Show)
instance Enum InitFlag where
toEnum 1 = NoEnv
toEnum 2 = NoErrPrint
toEnum 4 = NoServerWarn
toEnum 8 = Debug
toEnum 128 = LogPid
toEnum 16 = NoAutoSys
toEnum 32 = Eintr
toEnum 64 = NoSigPipe
toEnum 256 = CheckC_EntEx
toEnum 768 = CheckC_Freq
toEnum i = error ("Network.DNS.ADNS.InitFlag cannot be mapped to value " ++ show i)
fromEnum NoEnv = 1
fromEnum NoErrPrint = 2
fromEnum NoServerWarn = 4
fromEnum Debug = 8
fromEnum LogPid = 128
fromEnum NoAutoSys = 16
fromEnum Eintr = 32
fromEnum NoSigPipe = 64
fromEnum CheckC_EntEx = 256
fromEnum CheckC_Freq = 768
data QueryFlag
= Search
| UseVC
| Owner
| QuoteOk_Query
| QuoteOk_CName
| QuoteOk_AnsHost
| QuoteFail_CName
| CName_Loose
| CName_Forbid
deriving (Eq, Bounded, Show)
instance Enum QueryFlag where
toEnum 1 = Search
toEnum 2 = UseVC
toEnum 4 = Owner
toEnum 16 = QuoteOk_Query
toEnum 0 = QuoteOk_CName
toEnum 64 = QuoteOk_AnsHost
toEnum 128 = QuoteFail_CName
toEnum 256 = CName_Loose
toEnum 512 = CName_Forbid
toEnum i = error ("Network.DNS.ADNS.QueryFlag cannot be mapped to value " ++ show i)
fromEnum Search = 1
fromEnum UseVC = 2
fromEnum Owner = 4
fromEnum QuoteOk_Query = 16
fromEnum QuoteOk_CName = 0
fromEnum QuoteOk_AnsHost = 64
fromEnum QuoteFail_CName = 128
fromEnum CName_Loose = 256
fromEnum CName_Forbid = 512
data RRType = A | CNAME | MX | NS | PTR
| NSEC
| RRType Int
deriving (Read)
instance Eq RRType where
a == b = fromEnum a == fromEnum b
instance Show RRType where
showsPrec _ x = case toEnum $ fromEnum x of
A -> showString "A"
CNAME -> showString "CNAME"
MX -> showString "MX"
NS -> showString "NS"
PTR -> showString "PTR"
NSEC -> showString "NSEC"
(RRType i) -> showString "TYPE" . shows i
instance Enum RRType where
toEnum 1 = A
toEnum 5 = CNAME
toEnum 65551 = MX
toEnum 65538 = NS
toEnum 65548 = PTR
toEnum x = case x .&. 65535 of
47 -> NSEC
i -> RRType i
fromEnum A = 1
fromEnum CNAME = 5
fromEnum MX = 65551
fromEnum NS = 65538
fromEnum PTR = 65548
fromEnum x = 262144 .|. case x of
NSEC -> 47
(RRType i) -> i
_ -> error "Missing case in fromEnum ADNS.Base.RRType"
instance Storable RRType where
sizeOf _ = (4)
alignment _ = alignment (undefined :: Word32)
poke ptr t = let p = castPtr ptr :: Ptr Word32
in poke p ((toEnum . fromEnum) t)
peek ptr = let p = castPtr ptr :: Ptr Word32
in peek p >>= return . toEnum . fromEnum
newtype Status = StatusCode Int
deriving (Eq, Show)
sOK :: Status
sOK = StatusCode 0
sNOMEMORY :: Status
sNOMEMORY = StatusCode 1
sUNKNOWNRRTYPE :: Status
sUNKNOWNRRTYPE = StatusCode 2
sSYSTEMFAIL :: Status
sSYSTEMFAIL = StatusCode 3
sMAX_LOCALFAIL :: Status
sMAX_LOCALFAIL = StatusCode 29
sTIMEOUT :: Status
sTIMEOUT = StatusCode 30
sALLSERVFAIL :: Status
sALLSERVFAIL = StatusCode 31
sNORECURSE :: Status
sNORECURSE = StatusCode 32
sINVALIDRESPONSE :: Status
sINVALIDRESPONSE = StatusCode 33
sUNKNOWNFORMAT :: Status
sUNKNOWNFORMAT = StatusCode 34
sMAX_REMOTEFAIL :: Status
sMAX_REMOTEFAIL = StatusCode 59
sRCODESERVFAIL :: Status
sRCODESERVFAIL = StatusCode 60
sRCODEFORMATERROR :: Status
sRCODEFORMATERROR = StatusCode 61
sRCODENOTIMPLEMENTED :: Status
sRCODENOTIMPLEMENTED = StatusCode 62
sRCODEREFUSED :: Status
sRCODEREFUSED = StatusCode 63
sRCODEUNKNOWN :: Status
sRCODEUNKNOWN = StatusCode 64
sMAX_TEMPFAIL :: Status
sMAX_TEMPFAIL = StatusCode 99
sINCONSISTENT :: Status
sINCONSISTENT = StatusCode 100
sPROHIBITEDCNAME :: Status
sPROHIBITEDCNAME = StatusCode 101
sANSWERDOMAININVALID :: Status
sANSWERDOMAININVALID = StatusCode 102
sANSWERDOMAINTOOLONG :: Status
sANSWERDOMAINTOOLONG = StatusCode 103
sINVALIDDATA :: Status
sINVALIDDATA = StatusCode 104
sMAX_MISCONFIG :: Status
sMAX_MISCONFIG = StatusCode 199
sQUERYDOMAINWRONG :: Status
sQUERYDOMAINWRONG = StatusCode 200
sQUERYDOMAININVALID :: Status
sQUERYDOMAININVALID = StatusCode 201
sQUERYDOMAINTOOLONG :: Status
sQUERYDOMAINTOOLONG = StatusCode 202
sMAX_MISQUERY :: Status
sMAX_MISQUERY = StatusCode 299
sNXDOMAIN :: Status
sNXDOMAIN = StatusCode 300
sNODATA :: Status
sNODATA = StatusCode 301
sMAX_PERMFAIL :: Status
sMAX_PERMFAIL = StatusCode 499
newtype RRAddr = RRAddr HostAddress
deriving (Eq)
instance Show RRAddr where
show (RRAddr ha) = shows b1 . ('.':) .
shows b2 . ('.':) .
shows b3 . ('.':) .
shows b4 $ ""
where
(b1,b2,b3,b4) = readWord32 ha
instance Storable RRAddr where
sizeOf _ = (20)
alignment _ = alignment (undefined :: CInt)
poke _ _ = fail "poke is undefined for Network.DNS.ADNS.RRAddr"
peek ptr' = do
let ptr = (\hsc_ptr -> hsc_ptr `plusPtr` 4) ptr'
t <- (\hsc_ptr -> peekByteOff hsc_ptr 0) ptr :: IO Word16
if (t /= 2)
then fail ("peek Network.DNS.ADNS.RRAddr: unsupported 'sockaddr' type " ++ show t)
else (\hsc_ptr -> peekByteOff hsc_ptr 4) ptr >>= return . RRAddr
data RRHostAddr = RRHostAddr HostName Status [RRAddr]
deriving (Show)
instance Storable RRHostAddr where
sizeOf _ = (16)
alignment _ = alignment (undefined :: CString)
poke _ _ = fail "poke is undefined for Network.DNS.ADNS.RRHostAddr"
peek ptr = do
h <- (\hsc_ptr -> peekByteOff hsc_ptr 0) ptr
hstr <- assert (h /= nullPtr) (peekCString h)
st <- (\hsc_ptr -> peekByteOff hsc_ptr 4) ptr
nadr <- (\hsc_ptr -> peekByteOff hsc_ptr 8) ptr :: IO Word32
aptr <- (\hsc_ptr -> peekByteOff hsc_ptr 12) ptr
adrs <- if (nadr > 0)
then peekArray (fromEnum nadr) aptr
else return []
return (RRHostAddr hstr (StatusCode st) adrs)
data RRIntHostAddr = RRIntHostAddr Int RRHostAddr
deriving (Show)
instance Storable RRIntHostAddr where
sizeOf _ = (20)
alignment _ = alignment (undefined :: CInt)
poke _ _ = fail "poke is undefined for Network.DNS.ADNS.RRIntHostAddr"
peek ptr = do
i <- (\hsc_ptr -> peekByteOff hsc_ptr 0) ptr :: IO CInt
a <- (\hsc_ptr -> peekByteOff hsc_ptr 4) ptr
return (RRIntHostAddr (fromEnum i) a)
data RRByteblock = RRByteblock Int (Ptr CChar)
instance Storable RRByteblock where
sizeOf _ = (8)
alignment _ = alignment (undefined :: CInt)
poke _ _ = fail "poke is undefined for Network.DNS.ADNS.RRByteblock"
peek ptr = do
l <- (\hsc_ptr -> peekByteOff hsc_ptr 0) ptr :: IO CInt
p <- (\hsc_ptr -> peekByteOff hsc_ptr 4) ptr
return (RRByteblock (fromEnum l) p)
data Answer = Answer
{ status :: Status
, cname :: Maybe String
, owner :: Maybe String
, expires :: CTime
, rrs :: [Response]
}
deriving (Show)
data Response
= RRA RRAddr
| RRCNAME String
| RRMX Int RRHostAddr
| RRNS RRHostAddr
| RRPTR String
| RRNSEC String
| RRUNKNOWN String
deriving (Show)
instance Storable Answer where
sizeOf _ = (32)
alignment _ = alignment (undefined :: CInt)
poke _ _ = fail "poke is not defined for Network.DNS.ADNS.Answer"
peek ptr = do
sc <- (\hsc_ptr -> peekByteOff hsc_ptr 0) ptr
cn <- (\hsc_ptr -> peekByteOff hsc_ptr 4) ptr >>= maybePeek peekCString
ow <- (\hsc_ptr -> peekByteOff hsc_ptr 8) ptr >>= maybePeek peekCString
et <- (\hsc_ptr -> peekByteOff hsc_ptr 16) ptr
rt <- (\hsc_ptr -> peekByteOff hsc_ptr 12) ptr
rs <- (\hsc_ptr -> peekByteOff hsc_ptr 20) ptr :: IO CInt
sz <- ((\hsc_ptr -> peekByteOff hsc_ptr 24) ptr) :: IO CInt
rrsp <- (\hsc_ptr -> peekByteOff hsc_ptr 28) ptr
r <- peekResp rt rrsp (fromEnum sz) (fromEnum rs)
return Answer
{ status = StatusCode sc
, cname = cn
, owner = ow
, expires = et
, rrs = r
}
peekResp :: RRType -> Ptr b -> Int -> Int -> IO [Response]
peekResp _ _ _ 0 = return []
peekResp rt ptr off n = do
r <- parseByType (toEnum $ fromEnum rt)
rs <- peekResp rt (ptr `plusPtr` off) off (n1)
return (r:rs)
where
parseByType A = peek (castPtr ptr) >>= return . RRA . RRAddr
parseByType NS = peek (castPtr ptr) >>= return . RRNS
parseByType PTR = peek (castPtr ptr) >>= peekCString >>= return . RRPTR
parseByType MX = do (RRIntHostAddr i addr) <- peek (castPtr ptr)
return (RRMX i addr)
parseByType CNAME = peek (castPtr ptr) >>= peekCString >>= return . RRCNAME
parseByType NSEC = do RRByteblock len rptr <- peek (castPtr ptr)
(name, _) <- peekFQDNAndAdvance rptr len
return $ RRNSEC name
parseByType (RRType _) = do RRByteblock len rptr <- peek (castPtr ptr)
str <- peekCStringLen (rptr, len)
return $ RRUNKNOWN str
peekFQDNAndAdvance :: Ptr a -> Int -> IO (String, Ptr a)
peekFQDNAndAdvance ptr _ = do
cc <- peek (castPtr ptr :: Ptr CChar)
let ptr1 = ptr `plusPtr` 1
case fromEnum cc of
c | c == 0 -> return ("", ptr1)
| c < 64 -> do name <- peekCStringLen (castPtr ptr1, c)
(zone, ptr2) <- peekFQDNAndAdvance (ptr1 `plusPtr` c) 0
return (name ++ "." ++ zone, ptr2)
| otherwise -> error "Compressed FQDN must not occur here."
adnsInit :: [InitFlag] -> (AdnsState -> IO a) -> IO a
adnsInit flags =
bracket
(wrapAdns (\p -> adns_init p (mkFlags flags) nullPtr) peek)
adns_finish
adnsInitCfg :: [InitFlag] -> String -> (AdnsState -> IO a) -> IO a
adnsInitCfg flags cfg = bracket mkState adns_finish
where
mkState = withCString cfg $ \cstr ->
wrapAdns
(\p -> adns_init_strcfg p (mkFlags flags) nullPtr cstr)
peek
adnsSynch :: AdnsState -> String -> RRType -> [QueryFlag] -> IO Answer
adnsSynch st own rrt flags =
withCString own $ \o -> do
let rrt' = (toEnum . fromEnum) rrt
wrapAdns
(adns_synchronous st o rrt' (mkFlags flags))
(\p -> peek p >>= peek)
adnsSubmit :: AdnsState -> String -> RRType -> [QueryFlag] -> IO Query
adnsSubmit st own rrt flags =
withCString own $ \o -> do
let rrt' = (toEnum . fromEnum) rrt
wrapAdns
(adns_submit st o rrt' (mkFlags flags) nullPtr)
(peek)
adnsCheck :: AdnsState -> Query -> IO (Maybe Answer)
adnsCheck st q =
alloca $ \qPtr ->
alloca $ \aPtr -> do
poke qPtr q
poke aPtr nullPtr
rc <- adns_check st qPtr aPtr nullPtr
case rc of
0 -> peek aPtr >>= peek >>= return . Just
11 -> return Nothing
_ -> do p <- adns_strerror rc
s <- peekCString p
fail ("adnsCheck: " ++ s)
adnsWait :: AdnsState -> IO (Maybe (Query,Answer))
adnsWait st =
alloca $ \qPtr ->
alloca $ \aPtr -> do
poke qPtr nullPtr
poke aPtr nullPtr
rc <- adns_wait st qPtr aPtr nullPtr
case rc of
0 -> do q <- peek qPtr
a' <- peek aPtr
a <- peek a'
free a'
return (Just (q,a))
3 -> return Nothing
_ -> do p <- adns_strerror rc
s <- peekCString p
fail ("adnsWait: " ++ s)
foreign import ccall unsafe "adns_cancel" adnsCancel :: Query -> IO ()
foreign import ccall safe adns_wait ::
AdnsState -> Ptr Query -> Ptr (Ptr Answer) -> Ptr (Ptr a) -> IO CInt
adnsQueries :: AdnsState -> IO [Query]
adnsQueries st = adns_forallqueries_begin st >> walk
where walk = do q <- adns_forallqueries_next st nullPtr
if (q /= nullPtr)
then walk >>= return . ((:) q)
else return []
adnsStrerror :: Status -> IO String
adnsStrerror (StatusCode x) = do
cstr <- (adns_strerror . toEnum . fromEnum) x
assert (cstr /= nullPtr) (peekCString cstr)
adnsErrAbbrev :: Status -> IO String
adnsErrAbbrev (StatusCode x) = do
cstr <- (adns_errabbrev . toEnum . fromEnum) x
assert (cstr /= nullPtr) (peekCString cstr)
adnsErrTypeAbbrev :: Status -> IO String
adnsErrTypeAbbrev (StatusCode x) = do
cstr <- (adns_errtypeabbrev . toEnum . fromEnum) x
assert (cstr /= nullPtr) (peekCString cstr)
foreign import ccall unsafe adns_init ::
Ptr AdnsState -> CInt -> Ptr CFile -> IO CInt
foreign import ccall unsafe adns_init_strcfg ::
Ptr AdnsState -> CInt -> Ptr CFile -> CString-> IO CInt
foreign import ccall unsafe adns_finish ::
AdnsState -> IO ()
foreign import ccall unsafe adns_submit ::
AdnsState -> CString -> CInt -> CInt -> Ptr a -> Ptr Query
-> IO CInt
foreign import ccall unsafe adns_check ::
AdnsState -> Ptr Query -> Ptr (Ptr Answer) -> Ptr (Ptr a)
-> IO CInt
foreign import ccall unsafe adns_synchronous ::
AdnsState -> CString -> CInt -> CInt -> Ptr (Ptr Answer)
-> IO CInt
foreign import ccall unsafe adns_forallqueries_begin ::
AdnsState -> IO ()
foreign import ccall unsafe adns_forallqueries_next ::
AdnsState -> Ptr (Ptr a) -> IO Query
foreign import ccall unsafe adns_strerror :: CInt -> IO CString
foreign import ccall unsafe adns_errabbrev :: CInt -> IO CString
foreign import ccall unsafe adns_errtypeabbrev :: CInt -> IO CString
wrapAdns :: (Ptr (Ptr b) -> IO CInt) -> (Ptr (Ptr b) -> IO a) -> IO a
wrapAdns m acc = alloca $ \resP -> do
poke resP nullPtr
rc <- m resP
if (rc == 0)
then acc resP
else do p <- adns_strerror rc
s <- peekCString p
fail ("ADNS: " ++ s)
mkFlags :: Enum a => [a] -> CInt
mkFlags = toEnum . sum . map fromEnum