hsdns (empty) → 1.0
raw patch · 9 files changed
+990/−0 lines, 9 filesdep +basedep +networkbuild-type:Customsetup-changed
Dependencies added: base, network
Files
- ADNS.hs +43/−0
- ADNS/Base.hsc +545/−0
- ADNS/Endian.hs +69/−0
- ADNS/Resolver.hs +178/−0
- README +57/−0
- Setup.lhs +8/−0
- example/adns-reverse-lookup.hs +60/−0
- hsdns.cabal +25/−0
- prologue.txt +5/−0
+ ADNS.hs view
@@ -0,0 +1,43 @@+{- |+ Module : ADNS+ Copyright : (c) 2007 Peter Simons+ License : LGPL++ Maintainer : simons@cryp.to+ Stability : provisional+ Portability : portable++ An asynchronous DNS resolver based on GNU ADNS+ <http://www.gnu.org/software/adns/>. You should link your+ program with the /threaded/ runtime-system when using this+ module. In GHC, this is accomplished by specifying @-threaded@+ on the command-line.+-}++module ADNS+ ( HostName, HostAddress+ , Resolver, initResolver, InitFlag(..)+ , queryA, queryPTR, queryMX+ , dummyDNS+ )+ where++import Network ( HostName )+import Network.Socket ( HostAddress )+import ADNS.Base+import ADNS.Resolver++queryA :: Resolver -> HostName -> IO (Maybe [HostAddress])+queryA = query resolveA++queryPTR :: Resolver -> HostAddress -> IO (Maybe [HostName])+queryPTR = query resolvePTR++queryMX :: Resolver -> HostName -> IO (Maybe [(HostName, HostAddress)])+queryMX = query resolveMX++-- ----- Configure Emacs -----+--+-- Local Variables: ***+-- haskell-program-name: "ghci -ladns" ***+-- End: ***
+ ADNS/Base.hsc view
@@ -0,0 +1,545 @@+{-# OPTIONS -fffi #-}+{- |+ Module : ADNS.Base+ Copyright : (c) 2007 by Peter Simons+ License : GPL2++ Maintainer : simons@cryp.to+ Stability : provisional+ Portability : ForeignFunctionInterface++ This module provides bindings to GNU ADNS, a domain name+ resolver library written in C. ADNS is available from+ <http://www.gnu.org/software/adns/>.++ You will most likely not need this module directly: "ADNS"+ provides a simpler for the Haskell world; this module contains+ mostly marshaling code.+ -}++module ADNS.Base where++import Control.Exception ( assert, bracket )+import Network ( HostName )+import Network.Socket ( HostAddress )+import Foreign+import Foreign.C+import ADNS.Endian++#include <adns.h>+#include <errno.h>++-- * Marshaled ADNS Data Types++data OpaqueState = OpaqueState+type AdnsState = Ptr OpaqueState++data OpaqueQuery = OpaqueQuery+type Query = Ptr OpaqueQuery++data InitFlag+ = NoEnv -- ^ do not look at environment+ | NoErrPrint -- ^ never print output to stderr ('Debug' overrides)+ | NoServerWarn -- ^ do not warn to stderr about duff nameservers etc+ | Debug -- ^ enable all output to stderr plus 'Debug' msgs+ | LogPid -- ^ include process id in diagnostic output+ | NoAutoSys -- ^ do not make syscalls at every opportunity+ | Eintr -- ^ allow 'adnsSynch' to return 'eINTR'+ | NoSigPipe -- ^ application has SIGPIPE set to SIG_IGN, do not protect+ | CheckC_EntEx -- ^ do consistency checks on entry\/exit to adns functions+ | CheckC_Freq -- ^ do consistency checks very frequently (slow!)+ deriving (Eq, Bounded, Show)++instance Enum InitFlag where+ toEnum #{const adns_if_noenv} = NoEnv+ toEnum #{const adns_if_noerrprint} = NoErrPrint+ toEnum #{const adns_if_noserverwarn} = NoServerWarn+ toEnum #{const adns_if_debug} = Debug+ toEnum #{const adns_if_logpid} = LogPid+ toEnum #{const adns_if_noautosys} = NoAutoSys+ toEnum #{const adns_if_eintr} = Eintr+ toEnum #{const adns_if_nosigpipe} = NoSigPipe+ toEnum #{const adns_if_checkc_entex} = CheckC_EntEx+ toEnum #{const adns_if_checkc_freq} = CheckC_Freq+ toEnum i = error ("Network.DNS.ADNS.InitFlag cannot be mapped to value " ++ show i)++ fromEnum NoEnv = #{const adns_if_noenv}+ fromEnum NoErrPrint = #{const adns_if_noerrprint}+ fromEnum NoServerWarn = #{const adns_if_noserverwarn}+ fromEnum Debug = #{const adns_if_debug}+ fromEnum LogPid = #{const adns_if_logpid}+ fromEnum NoAutoSys = #{const adns_if_noautosys}+ fromEnum Eintr = #{const adns_if_eintr}+ fromEnum NoSigPipe = #{const adns_if_nosigpipe}+ fromEnum CheckC_EntEx = #{const adns_if_checkc_entex}+ fromEnum CheckC_Freq = #{const adns_if_checkc_freq}++data QueryFlag+ = Search -- ^ use the searchlist+ | UseVC -- ^ use a virtual circuit (TCP connection)+ | Owner -- ^ fill in the owner field in the answer+ | QuoteOk_Query -- ^ allow special chars in query domain+ | QuoteOk_CName -- ^ allow special chars in CNAME we go via (default)+ | QuoteOk_AnsHost -- ^ allow special chars in things supposed to be hostnames+ | QuoteFail_CName -- ^ refuse if quote-req chars in CNAME we go via+ | CName_Loose -- ^ allow refs to CNAMEs - without, get _s_cname+ | CName_Forbid -- ^ don't follow CNAMEs, instead give _s_cname+ deriving (Eq, Bounded, Show)++instance Enum QueryFlag where+ toEnum #{const adns_qf_search} = Search+ toEnum #{const adns_qf_usevc} = UseVC+ toEnum #{const adns_qf_owner} = Owner+ toEnum #{const adns_qf_quoteok_query} = QuoteOk_Query+ toEnum #{const adns_qf_quoteok_cname} = QuoteOk_CName+ toEnum #{const adns_qf_quoteok_anshost} = QuoteOk_AnsHost+ toEnum #{const adns_qf_quotefail_cname} = QuoteFail_CName+ toEnum #{const adns_qf_cname_loose} = CName_Loose+ toEnum #{const adns_qf_cname_forbid} = CName_Forbid+ toEnum i = error ("Network.DNS.ADNS.QueryFlag cannot be mapped to value " ++ show i)++ fromEnum Search = #{const adns_qf_search}+ fromEnum UseVC = #{const adns_qf_usevc}+ fromEnum Owner = #{const adns_qf_owner}+ fromEnum QuoteOk_Query = #{const adns_qf_quoteok_query}+ fromEnum QuoteOk_CName = #{const adns_qf_quoteok_cname}+ fromEnum QuoteOk_AnsHost = #{const adns_qf_quoteok_anshost}+ fromEnum QuoteFail_CName = #{const adns_qf_quotefail_cname}+ fromEnum CName_Loose = #{const adns_qf_cname_loose}+ fromEnum CName_Forbid = #{const adns_qf_cname_forbid}++-- |The record types we support.++data RRType = A | MX | NS | PTR+ deriving (Eq, Bounded, Show)++instance Enum RRType where+ toEnum #{const adns_r_a} = A+ toEnum #{const adns_r_mx} = MX+ toEnum #{const adns_r_ns} = NS+ toEnum #{const adns_r_ptr} = PTR+ toEnum i = error ("Network.DNS.ADNS.RRType cannot be mapped to value " ++ show i)++ fromEnum A = #{const adns_r_a}+ fromEnum MX = #{const adns_r_mx}+ fromEnum NS = #{const adns_r_ns}+ fromEnum PTR = #{const adns_r_ptr}++instance Storable RRType where+ sizeOf _ = #{size adns_rrtype}+ alignment _ = alignment (undefined :: #{type adns_rrtype})+ poke ptr t = let p = castPtr ptr :: Ptr #{type adns_rrtype}+ in poke p ((toEnum . fromEnum) t)+ peek ptr = let p = castPtr ptr :: Ptr #{type adns_rrtype}+ in peek p >>= return . toEnum . fromEnum++-- |The status codes recognized by ADNS vary in different+-- versions of the library. So instead of providing an+-- 'Enum', the 'Status' type contains the numeric value as+-- returned by ADNS itself. For common status codes, helper+-- functions like 'sOK' or 'sNXDOMAIN' are provided. The+-- functions 'adnsErrTypeAbbrev', 'adnsErrAbbrev', and+-- 'adnsStrerror' can also be used to map these codes into+-- human readable strings.++newtype Status = StatusCode Int+ deriving (Eq, Show)++#enum Status, StatusCode \+ , sOK = adns_s_ok \+ , sNOMEMORY = adns_s_nomemory \+ , sUNKNOWNRRTYPE = adns_s_unknownrrtype \+ , sSYSTEMFAIL = adns_s_systemfail \+ , sMAX_LOCALFAIL = adns_s_max_localfail \+ , sTIMEOUT = adns_s_timeout \+ , sALLSERVFAIL = adns_s_allservfail \+ , sNORECURSE = adns_s_norecurse \+ , sINVALIDRESPONSE = adns_s_invalidresponse \+ , sUNKNOWNFORMAT = adns_s_unknownformat \+ , sMAX_REMOTEFAIL = adns_s_max_remotefail \+ , sRCODESERVFAIL = adns_s_rcodeservfail \+ , sRCODEFORMATERROR = adns_s_rcodeformaterror \+ , sRCODENOTIMPLEMENTED = adns_s_rcodenotimplemented \+ , sRCODEREFUSED = adns_s_rcoderefused \+ , sRCODEUNKNOWN = adns_s_rcodeunknown \+ , sMAX_TEMPFAIL = adns_s_max_tempfail \+ , sINCONSISTENT = adns_s_inconsistent \+ , sPROHIBITEDCNAME = adns_s_prohibitedcname \+ , sANSWERDOMAININVALID = adns_s_answerdomaininvalid \+ , sANSWERDOMAINTOOLONG = adns_s_answerdomaintoolong \+ , sINVALIDDATA = adns_s_invaliddata \+ , sMAX_MISCONFIG = adns_s_max_misconfig \+ , sQUERYDOMAINWRONG = adns_s_querydomainwrong \+ , sQUERYDOMAININVALID = adns_s_querydomaininvalid \+ , sQUERYDOMAINTOOLONG = adns_s_querydomaintoolong \+ , sMAX_MISQUERY = adns_s_max_misquery \+ , sNXDOMAIN = adns_s_nxdomain \+ , sNODATA = adns_s_nodata \+ , sMAX_PERMFAIL = adns_s_max_permfail++-- |Original definition:+--+-- > typedef struct {+-- > int len;+-- > union {+-- > struct sockaddr sa;+-- > struct sockaddr_in inet;+-- > } addr;+-- > } adns_rr_addr;+--+-- /Note/: Anything but @sockaddr_in@ will cause 'peek' to call 'fail',+-- when marshaling this structure. 'poke' is not defined.++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 _ = #{size adns_rr_addr}+ alignment _ = alignment (undefined :: CInt)+ poke _ _ = fail "poke is undefined for Network.DNS.ADNS.RRAddr"+ peek ptr' = do+ let ptr = #{ptr adns_rr_addr, addr} ptr'+ t <- #{peek struct sockaddr_in, sin_family} ptr :: IO #{type sa_family_t}+ if (t /= #{const AF_INET})+ then fail ("peek Network.DNS.ADNS.RRAddr: unsupported 'sockaddr' type " ++ show t)+ else #{peek struct sockaddr_in, sin_addr} ptr >>= return . RRAddr++-- |Original definition:+--+-- > typedef struct {+-- > char *host;+-- > adns_status astatus;+-- > int naddrs; /* temp fail => -1, perm fail => 0, s_ok => >0+-- > adns_rr_addr *addrs;+-- > } adns_rr_hostaddr;+--+-- The @naddrs@ field is not available in @RRHostAddr@+-- because I couldn't see how that information wouldn't be+-- available in the @astatus@ field too. If I missed+-- anything, please let me know.+--+-- /Note/: The data type should probably contain+-- 'HostAddress' rather than 'RRAddr'. I'm using the former+-- only because it has nicer output with 'show'. 'poke' is+-- not defined.++data RRHostAddr = RRHostAddr HostName Status [RRAddr]+ deriving (Show)++instance Storable RRHostAddr where+ sizeOf _ = #{size adns_rr_hostaddr}+ alignment _ = alignment (undefined :: CString)+ poke _ _ = fail "poke is undefined for Network.DNS.ADNS.RRHostAddr"+ peek ptr = do+ h <- #{peek adns_rr_hostaddr, host} ptr+ hstr <- assert (h /= nullPtr) (peekCString h)+ st <- #{peek adns_rr_hostaddr, astatus} ptr+ nadr <- #{peek adns_rr_hostaddr, naddrs} ptr :: IO #{type adns_status}+ aptr <- #{peek adns_rr_hostaddr, addrs} ptr+ adrs <- if (nadr > 0)+ then peekArray (fromEnum nadr) aptr+ else return []+ return (RRHostAddr hstr (StatusCode st) adrs)++-- |Original definition:+--+-- > typedef struct {+-- > int i;+-- > adns_rr_hostaddr ha;+-- > } adns_rr_inthostaddr;++data RRIntHostAddr = RRIntHostAddr Int RRHostAddr+ deriving (Show)++instance Storable RRIntHostAddr where+ sizeOf _ = #{size adns_rr_inthostaddr}+ alignment _ = alignment (undefined :: CInt)+ poke _ _ = fail "poke is undefined for Network.DNS.ADNS.RRIntHostAddr"+ peek ptr = do+ i <- #{peek adns_rr_inthostaddr, i} ptr :: IO CInt+ a <- #{peek adns_rr_inthostaddr, ha} ptr+ return (RRIntHostAddr (fromEnum i) a)++data Answer = Answer+ { status :: Status+ -- ^ Status code for this query.+ , cname :: Maybe String+ -- ^ Always 'Nothing' for @CNAME@ queries (which are not supported yet anyway).+ , owner :: Maybe String+ -- ^ Only set if 'Owner' was requested for query.+ , expires :: CTime+ -- ^ Only defined if status is 'sOK', 'sNXDOMAIN', or 'sNODATA'.+ , rrs :: [Response]+ -- ^ The list will be empty if an error occured.+ }+ deriving (Show)++data Response+ = RRA RRAddr+ | RRMX Int RRHostAddr+ | RRNS RRHostAddr+ | RRPTR String+ deriving (Show)++instance Storable Answer where+ sizeOf _ = #{size adns_answer}+ alignment _ = alignment (undefined :: CInt)+ poke _ _ = fail "poke is not defined for Network.DNS.ADNS.Answer"+ peek ptr = do+ sc <- #{peek adns_answer, status} ptr+ cn <- #{peek adns_answer, cname} ptr >>= maybePeek peekCString+ ow <- #{peek adns_answer, owner} ptr >>= maybePeek peekCString+ et <- #{peek adns_answer, expires} ptr+ rt <- #{peek adns_answer, type} ptr+ rs <- #{peek adns_answer, nrrs} ptr :: IO CInt+ sz <- (#{peek adns_answer, rrsz} ptr) :: IO CInt+ rrsp <- #{peek adns_answer, rrs} ptr+ r <- peekResp rt rrsp (fromEnum sz) (fromEnum rs)+ return Answer+ { status = StatusCode sc+ , cname = cn+ , owner = ow+ , expires = et+ , rrs = r+ }++-- |This function parses the 'Response' union found in+-- 'Answer'. It cannot be defined via 'Storable' because it+-- needs to know the type of the record to expect. This is,+-- by the way, the function to look at, if you want to add+-- support for additional 'RRType' records.++peekResp :: RRType -> Ptr b -> Int -> Int -> IO [Response]+peekResp _ _ _ 0 = return []+peekResp rt ptr off n = do+ r <- parseByType rt+ rs <- peekResp rt (ptr `plusPtr` off) off (n-1)+ 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)++-- * ADNS Library Functions++-- |Run the given 'IO' computation with an initialized+-- resolver. As of now, the diagnose stream is always set to+-- 'System.IO.stderr'. Initialize the library with 'NoErrPrint' if you+-- don't wont to see any error output. All resources are+-- freed when @adnsInit@ returns.++adnsInit :: [InitFlag] -> (AdnsState -> IO a) -> IO a+adnsInit flags =+ bracket+ (wrapAdns (\p -> adns_init p (mkFlags flags) nullPtr) peek)+ adns_finish++-- |Similar to 'adnsInit', but reads the resolver+-- configuration from a string rather than from+-- @\/etc\/resolv.conf@. Supported are the usual commands:+-- @nameserver@, @search@, @domain@, @sortlist@, and+-- @options@.+--+-- Additionally, these non-standard commands may be used:+--+-- * @clearnameservers@: Clears the list of nameservers.+--+-- * @include filename@: The specified file will be read.++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++-- |Perform a synchronous query for a record. In case of an+-- I\/O error, an 'System.IO.Error.IOException' is thrown.+-- If the query fails for other reasons, the 'Status' code+-- in the 'Answer' will signify that.++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)++-- |Submit an asynchronous query. The returned 'Query' can+-- be tested for completion with 'adnsCheck'.++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)++-- |Check the status of an asynchronous query. If the query+-- is complete, the 'Answer' will be returned. The 'Query'+-- becomes invalid after that.++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+ #{const EAGAIN} -> return Nothing+ _ -> do p <- adns_strerror rc+ s <- peekCString p+ fail ("adnsCheck: " ++ s)++-- |Wait for a response to arrive. The returned 'Query' is+-- invalid and must not be passed to ADNS again. If 'Nothing' is+-- returned, the resolver is empty.++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))+ #{const ESRCH} -> return Nothing+ _ -> do p <- adns_strerror rc+ s <- peekCString p+ fail ("adnsWait: " ++ s)++-- |Cancel an open 'Query'.++foreign import ccall unsafe "adns_cancel" adnsCancel :: Query -> IO ()++-- |Wait for the next 'Query' to become available.++foreign import ccall safe adns_wait ::+ AdnsState -> Ptr Query -> Ptr (Ptr Answer) -> Ptr (Ptr a) -> IO CInt++-- |Return the list of all currently open queries.++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 []+++-- |Map a 'Status' code to a human-readable error+-- description. For example:+--+-- > *ADNS> adnsStrerror sNXDOMAIN >>= print+-- > "No such domain"+--+-- Use this function with great care: It will crash the+-- process when called with a status code that ADNS doesn't+-- know about. So use it only to print values you got from+-- the resolver!++adnsStrerror :: Status -> IO String+adnsStrerror (StatusCode x) = do+ cstr <- (adns_strerror . toEnum . fromEnum) x+ assert (cstr /= nullPtr) (peekCString cstr)++-- |Map a 'Status' code to a short error name. Don't use+-- this function to print a status code unless you've+-- obtained it from the resolver!++adnsErrAbbrev :: Status -> IO String+adnsErrAbbrev (StatusCode x) = do+ cstr <- (adns_errabbrev . toEnum . fromEnum) x+ assert (cstr /= nullPtr) (peekCString cstr)++-- |Map a 'Status' code to a short description of the type+-- of error. Don't use this function to print a status code+-- unless you've obtained it from the resolver!++adnsErrTypeAbbrev :: Status -> IO String+adnsErrTypeAbbrev (StatusCode x) = do+ cstr <- (adns_errtypeabbrev . toEnum . fromEnum) x+ assert (cstr /= nullPtr) (peekCString cstr)++-- * Unmarshaled Low-Level C Functions++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++-- * Helper Functions++-- |Internel helper function to handle result passing from+-- ADNS via @Ptr (Ptr a)@, and to generate human-readable IO+-- exceptions in case of an error.++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)++-- |Map a list of flags ('Enum' types) into a 'CInt'+-- suitable for adns calls.++mkFlags :: Enum a => [a] -> CInt+mkFlags = toEnum . sum . map fromEnum+++-- ----- Configure Emacs -----+--+-- Local Variables: ***+-- haskell-program-name: "ghci -ladns" ***+-- End: ***
+ ADNS/Endian.hs view
@@ -0,0 +1,69 @@+{- |+ Module : ADNS.Endian+ Copyright : (c) 2007 Peter Simons+ License : LGPL++ Maintainer : simons@cryp.to+ Stability : provisional+ Portability : portable++ Determine the machine's endian.+-}++module ADNS.Endian ( Endian(..), endian, readWord32, readWord16 ) where++import Foreign++-- |Signify the system's native byte order according to+-- significance of bytes from low addresses to high addresses.++data Endian+ = LittleEndian -- ^ byte order: @1234@+ | BigEndian -- ^ byte order: @4321@+ | PDPEndian -- ^ byte order: @3412@+ deriving (Show, Eq)++-- |The endian of this machine, determined at run-time.++{-# NOINLINE endian #-}+endian :: Endian+endian =+ unsafePerformIO $+ allocaArray (sizeOf (undefined :: Word32)) $ \p -> do+ let val = 0x01020304 :: Word32+ poke p val+ let p' = castPtr p :: Ptr Word8+ val' <- peekArray 4 p'+ case val' of+ (0x01:0x02:0x03:0x04:[]) -> return BigEndian+ (0x04:0x03:0x02:0x01:[]) -> return LittleEndian+ (0x03:0x04:0x01:0x02:[]) -> return PDPEndian+ _ -> error "unknown endian"++-- |Parse a host-ordered 32-bit word into a network-ordered tuple+-- of 8-bit words.++readWord32 :: Word32 -> (Word8, Word8, Word8, Word)+readWord32 n =+ let (b1,n1) = (n .&. 255, n `shiftR` 8)+ (b2,n2) = (n1 .&. 255, n1 `shiftR` 8)+ (b3,n3) = (n2 .&. 255, n2 `shiftR` 8)+ b4 = n3 .&. 255+ in+ case endian of+ BigEndian -> (fromIntegral b4, fromIntegral b3, fromIntegral b2, fromIntegral b1)+ LittleEndian -> (fromIntegral b1, fromIntegral b2, fromIntegral b3, fromIntegral b4)+ PDPEndian -> (fromIntegral b2, fromIntegral b1, fromIntegral b4, fromIntegral b3)++-- |Parse a host-ordered 16-bit word into a network-ordered tuple of+-- 8-bit words.++readWord16 :: Word16 -> (Word8, Word8)+readWord16 n =+ let (b1,n1) = (n .&. 255, n `shiftR` 8)+ b2 = n1 .&. 255+ in+ case endian of+ BigEndian -> (fromIntegral b2, fromIntegral b1)+ LittleEndian -> (fromIntegral b1, fromIntegral b2)+ PDPEndian -> (fromIntegral b2, fromIntegral b1)
+ ADNS/Resolver.hs view
@@ -0,0 +1,178 @@+{- |+ Module : ADNS.Resolver+ Copyright : (c) 2007 Peter Simons+ License : LGPL++ Maintainer : simons@cryp.to+ Stability : provisional+ Portability : portable++ This module implements a Haskell DNS Resolver on top of the+ ADNS library. GHC users should compile their code using the+ @-threaded@ runtime system.+ -}++module ADNS.Resolver+ ( Resolver+ , initResolver+ , toPTR+ , resolveA, resolvePTR, resolveMX+ , query+ , dummyDNS+ )+ where++import Control.Concurrent ( forkIO )+import Control.Concurrent.MVar+import Control.Monad ( when )+import Data.List ( sortBy )+import Data.Map ( Map )+import qualified Data.Map as Map+import Network ( HostName )+import Network.Socket ( HostAddress )+import ADNS.Base+import ADNS.Endian++-- |A 'Resolver' is an 'IO' computation which -- given the name+-- and type of the record to query -- returns an 'MVar' that will+-- eventually contain the 'Answer' from the Domain Name System.++type Resolver = String -> RRType -> [QueryFlag] -> IO (MVar Answer)++-- |Run the given 'IO' computation with an Initialized+-- 'Resolver'. Note that resolver functions can be shared,+-- and /should/ be shared between any number of 'IO'+-- threads. You may use multiple resolvers, of course, but+-- doing so defeats the purpose of an asynchronous resolver.++initResolver :: [InitFlag] -> (Resolver -> IO a) -> IO a+initResolver flags f =+ adnsInit flags $ \dns ->+ newMVar (RState dns Map.empty) >>= f . resolve++-- |Resolve a hostname's 'A' records.++resolveA :: Resolver -> HostName -> IO (Either Status [HostAddress])+resolveA resolver x = do+ Answer rc _ _ _ rs <- resolver x A [] >>= takeMVar+ if rc /= sOK+ then return (Left rc)+ else return (Right [ addr | RRA (RRAddr addr) <- rs ])++-- |Get the 'PTR' records assigned to a host address. Note+-- that although the API allows for a record to have more+-- than one 'PTR' entry, this will actually not happen+-- because the GNU adns library can't handle this case and+-- will return 'sINCONSISTENT'.++resolvePTR :: Resolver -> HostAddress -> IO (Either Status [HostName])+resolvePTR resolver x = do+ Answer rc _ _ _ rs <- resolver (toPTR x) PTR [] >>= takeMVar+ if rc /= sOK+ then return (Left rc)+ else return (Right [ addr | RRPTR addr <- rs ])++-- |Resolve the mail exchangers for a hostname. The returned+-- list may contain more than one entry per hostname, in+-- case the host has several 'A' records. The records are+-- returned in the order you should try to contact them as+-- determined by the priority in the 'RRMX' response.++resolveMX :: Resolver -> HostName -> IO (Either Status [(HostName, HostAddress)])+resolveMX resolver x = do+ Answer rc _ _ _ rs <- resolver x MX [] >>= takeMVar+ if rc /= sOK+ then return (Left rc)+ else do+ let cmp (RRMX p1 _) (RRMX p2 _) = compare p1 p2+ cmp _ _= error $ showString "unexpected record in MX lookup: " (show rs)+ rs' = sortBy cmp rs+ as = [ (hn,a) | RRMX _ (RRHostAddr hn stat has) <- rs'+ , stat == sOK && not (null has)+ , RRAddr a <- has ]+ return (Right as)++-- |Convenience wrapper that will modify any of the+-- @revolveXXX@ functions above to return 'Maybe' rather+-- than 'Either'. The idea is that @Nothing@ signifies any+-- sort of failure: @Just []@ signifies 'sNXDOMAIN' or+-- 'sNODATA', and everything else signifies 'sOK'.+--+-- So if you aren't interested in getting accurate 'Status'+-- codes in case of failures. Wrap your DNS queries as+-- follows:+--+-- > queryA :: Resolver -> HostName -> IO (Maybe [HostAddress])+-- > queryA = query resolveA++query :: (Resolver -> a -> IO (Either Status [b]))+ -> (Resolver -> a -> IO (Maybe [b]))+query f dns x = fmap toMaybe (f dns x)+ where+ toMaybe (Left rc)+ | rc == sNXDOMAIN = Just []+ | rc == sNODATA = Just []+ | otherwise = Nothing+ toMaybe (Right r) = Just r++-- |Use this function to disable DNS resolving. It will+-- always return @('Answer' 'sSYSTEMFAIL' Nothing (Just+-- host) (-1) [])@.++dummyDNS :: Resolver+dummyDNS host _ _ = newMVar+ (Answer sSYSTEMFAIL Nothing (Just host) (-1) [])++-- |Print an IP host address as a string suitable for 'PTR' lookups.++toPTR :: HostAddress -> String+toPTR ha = shows b4 . ('.':) .+ shows b3 . ('.':) .+ shows b2 . ('.':) .+ shows b1 $ ".in-addr.arpa."+ where+ (b1,b2,b3,b4) = readWord32 ha++-- * Implementation++-- |The internal state of the resolver is stored in an+-- 'MVar' so that it is shared (and synchronized) between+-- any number of concurrent 'IO' threads.++data ResolverState = RState+ { adns :: AdnsState -- ^ opaque ADNS state+ , queries :: Map Query (MVar Answer) -- ^ currently open queries+ }++-- |Submit a DNS query to the resolver and check whether we+-- have a running 'resolveLoop' thread already. If we don't,+-- start one with 'forkIO'. Make sure you link the threaded+-- RTS so that the main loop will not block other threads.++resolve :: MVar ResolverState -> Resolver+resolve mst r rt qfs = modifyMVar mst $ \st -> do+ res <- newEmptyMVar+ q <- adnsSubmit (adns st) r rt qfs+ when (Map.null (queries st))+ (forkIO (resolveLoop mst) >> return ())+ let st' = st { queries = Map.insert q res (queries st) }+ return (st', res)++-- |Loop until all open queries have been resolved.++resolveLoop :: MVar ResolverState -> IO ()+resolveLoop mst = do+ more <- modifyMVar mst $ \(RState dns qs) -> do+ r <- adnsWait dns+ case r of+ Nothing -> return (RState dns qs, False)+ Just (q,a) -> do mv <- Map.lookup q qs+ putMVar mv a+ return (RState dns (Map.delete q qs), True)+ when more (resolveLoop mst)++-- ----- Configure Emacs -----+--+-- Local Variables: ***+-- haskell-program-name: "ghci -ladns" ***+-- End: ***
+ README view
@@ -0,0 +1,57 @@+An asynchronous DNS resolver for Haskell_+=========================================++:Latest Release: hsdns-1.0.tar.gz_+:Darcs: darcs_ get http://cryp.to/hsdns/++Synopsis+--------++ This library provides an asynchronous DNS resolver on top of+ the `GNU ADNS library`_. Not all options are supported, but A,+ MX, and PTR lookups work fine. The code has been been tested+ with ADNS versions 1.0 to 1.4.++ The example program adns-reverse-lookup.hs_ demonstrates how+ the resolver is used. Given a list of host names on the command+ line, it performs an A/PTR double-lookup and checks whether the+ records are consistent. The output is printed in the order in+ which the DNS responses arrive::++ $ ./adns-reverse-lookup xyz.example.org ecrc.de www.example.com www.cryp.to+ OK: www.example.com <-> 208.77.188.166+ ERR: xyz.example.org: cannot resolve A+ FAIL: www.cryp.to -> 195.234.152.69 -> ["research.cryp.to"]+ FAIL: ecrc.de -> 127.0.0.1 -> ["localhost"]++Documentation+-------------++ `Reference Documentation`_+ Haddock-generated reference of all exported functions.++Copyleft+--------++ Copyright (c) 2007 Peter Simons <simons@cryp.to>. All rights+ reserved. This software is released under the terms of the `GNU+ Lesser General Public License+ <http://www.gnu.org/licenses/lgpl.html>`_.++-----------------------------------------------------------------++`[Homepage] <http://cryp.to/>`_++.. _Haskell: http://haskell.org/++.. _Cabal: http://haskell.org/cabal/++.. _darcs: http://abridgegame.org/darcs/++.. _GNU ADNS library: http://www.chiark.greenend.org.uk/~ian/adns/++.. _Reference Documentation: docs/index.html++.. _hsdns-1.0.tar.gz: http://cryp.to/hsdns/hsdns-1.0.tar.gz++.. _adns-reverse-lookup.hs: example/adns-reverse-lookup.hs
+ Setup.lhs view
@@ -0,0 +1,8 @@+#!/usr/bin/env runhaskell++> module Main (main) where+>+> import Distribution.Simple+>+> main :: IO ()+> main = defaultMain
+ example/adns-reverse-lookup.hs view
@@ -0,0 +1,60 @@+{-+ Resolve a bunch of hostnames' A records, then resolve those+ A-record's PTR records and check whether they match. Do it+ all asynchronously. The results are printed in the order the+ answers come in.++ TODO: handle hosts that have more than one A record+-}++module Main ( main ) where++import Control.Monad ( when, replicateM_ )+import Control.Concurrent ( forkIO )+import Control.Concurrent.Chan ( Chan, newChan, writeChan, readChan )+import System.Environment ( getArgs )+import Network.Socket ( inet_ntoa )+import Data.List ( elem )+import ADNS++data CheckResult+ = OK HostName HostAddress+ | NotOK HostName HostAddress [HostName]+ | DNSError String++printResult :: CheckResult -> IO ()+printResult (OK h a) = do addr <- inet_ntoa a+ putStrLn $ "OK: " ++ h ++ " <-> " ++ addr+printResult (NotOK h a h') = do addr <- inet_ntoa a+ putStrLn $ "FAIL: " ++ h ++ " -> " ++ addr ++ " -> " ++ show h'+printResult (DNSError msg) = putStrLn $ "ERR: " ++ msg++main :: IO ()+main = do+ names <- getArgs+ when (null names) (putStrLn "Usage: hostname [hostname ...]")+ initResolver [NoErrPrint, NoServerWarn] $ \resolver -> do+ rrChannel <- newChan :: IO (Chan CheckResult)+ mapM_ (\h -> forkIO (ptrCheck resolver rrChannel h)) names+ replicateM_ (length names) (readChan rrChannel >>= printResult)++ptrCheck :: Resolver -> Chan CheckResult -> HostName -> IO ()+ptrCheck resolver chan host = do+ let returnError t = writeChan chan (DNSError (host ++ ": cannot resolve " ++ t))+ a <- queryA resolver host+ case a of+ Just [addr] -> do+ ptr <- queryPTR resolver addr+ case ptr of+ Just names | host `elem` names -> writeChan chan (OK host addr)+ | otherwise -> writeChan chan (NotOK host addr names)+ _ -> returnError "PTR"+ _ -> returnError "A"++++-- ----- Configure Emacs -----+--+-- Local Variables: ***+-- haskell-program-name: "ghci -ladns" ***+-- End: ***
+ hsdns.cabal view
@@ -0,0 +1,25 @@+Name: hsdns+Version: 1.0+Author: Peter Simons <simons@cryp.to>+Maintainer: simons@cryp.to+License: LGPL+Homepage: http://cryp.to/hsdns/+Synopsis: Asynchronous DNS Resolver+Description: An asynchronous DNS resolver based on GNU ADNS.+Category: Foreign, Network+Build-Depends: base, network+Extensions: ForeignFunctionInterface+Extra-Libraries: adns+Includes: "adns.h", "errno.h"+Exposed-Modules: ADNS,+ ADNS.Base,+ ADNS.Endian,+ ADNS.Resolver+GHC-Options: -O -Wall+Data-Files: README, prologue.txt++Executable: adns-reverse-lookup+Hs-Source-Dirs: example, .+Main-Is: adns-reverse-lookup.hs+Extra-Libraries: adns+GHC-Options: -O -Wall -threaded
+ prologue.txt view
@@ -0,0 +1,5 @@+This package provides FFI bindings to the GNU ADNS library+<http://www.gnu.org/software/adns/> as well as an appropriate+high-level interface from the Haskell world. Not all options are+supported, but A, MX, and PTR lookups work fine. The code has+been been tested with ADNS versions 1.0 to 1.4.