diff --git a/ADNS.hs b/ADNS.hs
new file mode 100644
--- /dev/null
+++ b/ADNS.hs
@@ -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
+ . 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: ***
diff --git a/ADNS/Base.hsc b/ADNS/Base.hsc
new file mode 100644
--- /dev/null
+++ b/ADNS/Base.hsc
@@ -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
+ .
+
+ 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
+#include
+
+-- * 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: ***
diff --git a/ADNS/Endian.hs b/ADNS/Endian.hs
new file mode 100644
--- /dev/null
+++ b/ADNS/Endian.hs
@@ -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)
diff --git a/ADNS/Resolver.hs b/ADNS/Resolver.hs
new file mode 100644
--- /dev/null
+++ b/ADNS/Resolver.hs
@@ -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: ***
diff --git a/README b/README
new file mode 100644
--- /dev/null
+++ b/README
@@ -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 . All rights
+ reserved. This software is released under the terms of the `GNU
+ Lesser General Public License
+ `_.
+
+-----------------------------------------------------------------
+
+`[Homepage] `_
+
+.. _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
diff --git a/Setup.lhs b/Setup.lhs
new file mode 100644
--- /dev/null
+++ b/Setup.lhs
@@ -0,0 +1,8 @@
+#!/usr/bin/env runhaskell
+
+> module Main (main) where
+>
+> import Distribution.Simple
+>
+> main :: IO ()
+> main = defaultMain
diff --git a/example/adns-reverse-lookup.hs b/example/adns-reverse-lookup.hs
new file mode 100644
--- /dev/null
+++ b/example/adns-reverse-lookup.hs
@@ -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: ***
diff --git a/hsdns.cabal b/hsdns.cabal
new file mode 100644
--- /dev/null
+++ b/hsdns.cabal
@@ -0,0 +1,25 @@
+Name: hsdns
+Version: 1.0
+Author: Peter Simons
+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
diff --git a/prologue.txt b/prologue.txt
new file mode 100644
--- /dev/null
+++ b/prologue.txt
@@ -0,0 +1,5 @@
+This package provides FFI bindings to the GNU ADNS library
+ 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.