diff --git a/ADNS.hs b/ADNS.hs --- a/ADNS.hs +++ b/ADNS.hs @@ -17,18 +17,22 @@ module ADNS ( HostName, HostAddress , Resolver, initResolver, InitFlag(..) - , queryA, queryPTR, queryMX + , queryA, queryPTR, queryMX, querySRV , dummyDNS ) where -import Network ( HostName ) +import Network ( HostName, PortID ) import Network.Socket ( HostAddress ) import ADNS.Base import ADNS.Resolver queryA :: Resolver -> HostName -> IO (Maybe [HostAddress]) queryA = query resolveA + +-- | For quering SRV records. Result is the list of tuples (host, port) +querySRV :: Resolver -> HostName -> IO (Maybe [(HostName, PortID)]) +querySRV = query resolveSRV queryPTR :: Resolver -> HostAddress -> IO (Maybe [HostName]) queryPTR = query resolvePTR diff --git a/ADNS/Base.hsc b/ADNS/Base.hsc --- a/ADNS/Base.hsc +++ b/ADNS/Base.hsc @@ -112,6 +112,7 @@ data RRType = A | CNAME | MX | NS | PTR | NSEC + | SRV | RRType Int deriving (Read) @@ -126,6 +127,7 @@ NS -> showString "NS" PTR -> showString "PTR" NSEC -> showString "NSEC" + SRV -> showString "SRV" (RRType i) -> showString "TYPE" . shows i instance Enum RRType where @@ -134,6 +136,7 @@ toEnum #{const adns_r_mx} = MX toEnum #{const adns_r_ns} = NS toEnum #{const adns_r_ptr} = PTR + toEnum #{const adns_r_srv} = SRV toEnum x = case x .&. #{const adns_rrt_typemask} of 47 -> NSEC i -> RRType i @@ -143,6 +146,7 @@ fromEnum MX = #{const adns_r_mx} fromEnum NS = #{const adns_r_ns} fromEnum PTR = #{const adns_r_ptr} + fromEnum SRV = #{const adns_r_srv} fromEnum x = #{const adns_r_unknown} .|. case x of NSEC -> 47 (RRType i) -> i @@ -309,6 +313,26 @@ p <- #{peek adns_rr_byteblock, data} ptr return (RRByteblock (fromEnum l) p) +-- |Original definition: +-- +-- > typedef struct { +-- > int priority, weight, port; +-- > char *host; +-- > } adns_rr_srvraw; + +data RRSrvRaw = RRSrvRaw Int Int Int (Ptr CChar) + +instance Storable RRSrvRaw where + sizeOf _ = #{size adns_rr_srvraw} + alignment _ = alignment (undefined :: CInt) + poke _ _ = fail "poke is undefined for Network.DNS.ADNS.RRSrvRaw" + peek ptr = do + pr <- #{peek adns_rr_srvraw, priority} ptr :: IO CInt + w <- #{peek adns_rr_srvraw, weight} ptr :: IO CInt + po <- #{peek adns_rr_srvraw, port} ptr :: IO CInt + h <- #{peek adns_rr_srvraw, host} ptr + return (RRSrvRaw (fromEnum pr) (fromEnum w) (fromEnum po) h) + data Answer = Answer { status :: Status -- ^ Status code for this query. @@ -331,6 +355,7 @@ | RRPTR String | RRNSEC String | RRUNKNOWN String + | RRSRV Int Int Int String deriving (Show) instance Storable Answer where @@ -372,6 +397,9 @@ parseByType A = peek (castPtr ptr) >>= return . RRA . RRAddr parseByType NS = peek (castPtr ptr) >>= return . RRNS parseByType PTR = peek (castPtr ptr) >>= peekCString >>= return . RRPTR + parseByType SRV = do (RRSrvRaw prio weight port host) <- peek (castPtr ptr) + host' <- peekCString host + return (RRSRV prio weight port host') parseByType MX = do (RRIntHostAddr i addr) <- peek (castPtr ptr) return (RRMX i addr) parseByType CNAME = peek (castPtr ptr) >>= peekCString >>= return . RRCNAME diff --git a/ADNS/Resolver.hs b/ADNS/Resolver.hs --- a/ADNS/Resolver.hs +++ b/ADNS/Resolver.hs @@ -16,7 +16,7 @@ ( Resolver , initResolver , toPTR - , resolveA, resolvePTR, resolveMX + , resolveA, resolvePTR, resolveMX, resolveSRV , query , dummyDNS ) @@ -28,7 +28,7 @@ import Data.List ( sortBy ) import Data.Map ( Map ) import qualified Data.Map as Map -import Network ( HostName ) +import Network import Network.Socket ( HostAddress ) import ADNS.Base import ADNS.Endian @@ -58,6 +58,20 @@ if rc /= sOK then return (Left rc) else return (Right [ addr | RRA (RRAddr addr) <- rs ]) + +-- |Resolve a hostname's 'SRV' records. + +resolveSRV :: Resolver -> HostName -> IO (Either Status [(HostName, PortID)]) +resolveSRV resolver x = do + Answer rc _ _ _ rs <- resolver x SRV [] >>= takeMVar + if rc /= sOK + then return (Left rc) + else do + let cmp (RRSRV p1 _ _ _) (RRSRV p2 _ _ _) = compare p1 p2 + cmp _ _ = error $ showString "unexpected record in SRV lookup: " (show rs) + rs' = sortBy cmp rs + as = [ (host, PortNumber $ toEnum port) | (RRSRV _ _ port host) <- rs' ] + return (Right as) -- |Get the 'PTR' records assigned to a host address. Note -- that although the API allows for a record to have more diff --git a/README b/README --- a/README +++ b/README @@ -1,7 +1,7 @@ An asynchronous DNS resolver for Haskell_ ========================================= -:Latest Release: hsdns-1.4.tar.gz_ +:Latest Release: hsdns-1.4.1.tar.gz_ :Darcs: darcs_ get http://cryp.to/hsdns/ Synopsis @@ -56,6 +56,6 @@ .. _Reference Documentation: docs/index.html -.. _hsdns-1.4.tar.gz: http://cryp.to/hsdns/hsdns-1.4.tar.gz +.. _hsdns-1.4.1.tar.gz: http://cryp.to/hsdns/hsdns-1.4.1.tar.gz .. _adns-reverse-lookup.hs: example/adns-reverse-lookup.hs diff --git a/example/adns-reverse-lookup.hs b/example/adns-reverse-lookup.hs deleted file mode 100644 --- a/example/adns-reverse-lookup.hs +++ /dev/null @@ -1,60 +0,0 @@ -{- - 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/example/adns-test-and-traverse.hs b/example/adns-test-and-traverse.hs deleted file mode 100644 --- a/example/adns-test-and-traverse.hs +++ /dev/null @@ -1,49 +0,0 @@ -module Main where - -import ADNS -import ADNS.Base -import Control.Concurrent.MVar -import System.Environment - -main :: IO () -main = initResolver [NoErrPrint, NoServerWarn] $ \resolver -> do - args <- getArgs - case args of - [name] -> traverse resolver name - [t,name] -> work resolver (read t) name - _ -> putStrLn "Usage: t [typeid] fqdn" - --- | Test function to see the raw results of a given query type -work :: Resolver -> RRType -> String -> IO () -work resolver t n = do - putStrLn $ showString "Querying " . shows t $ showString " for " n - print =<< takeMVar =<< resolver n t [QuoteOk_Query] - --- | Example implementation to traverse a DNSSEC signed zone. --- --- This implementation is clearly wrong, because any real zone traversal --- is done using the NSEC records in the authority section of a NXDOMAIN --- response. --- --- Unfortunly the adns library does not provide access to other sections --- than the answer section, so this walk is done by querying NSEC directly. --- --- If there are signed subzones, the traversal switches to the subzone --- and stops if this subzone is traversed. You may continue the traversal --- by providing the next entry after the subzone. --- --- You may try this mechanism on "dnssec.iks-jena.de" -traverse :: Resolver -> String -> IO () -traverse resolver x = do - putStrLn x - answer <- takeMVar =<< resolver x NSEC [QuoteOk_Query] - case rrs answer of - [RRNSEC y] | not (x `endsWith` ('.':y)) -> traverse resolver y - _ -> return () - -endsWith :: String -> String -> Bool -endsWith x y = startsWith (reverse x) (reverse y) - -startsWith :: String -> String -> Bool -startsWith (x:xs) (y:ys) = x == y && startsWith xs ys -startsWith _ ys = null ys diff --git a/hsdns.cabal b/hsdns.cabal --- a/hsdns.cabal +++ b/hsdns.cabal @@ -1,7 +1,8 @@ Name: hsdns -Version: 1.4 +Version: 1.4.1 Author: Peter Simons , Lutz Donnerhacke + Григорий Холомьёв Maintainer: Peter Simons License: LGPL License-File: COPYING @@ -9,7 +10,7 @@ Synopsis: Asynchronous DNS Resolver Description: Asynchronous DNS Resolver; requires GNU ADNS to be installed. Category: Foreign, Network -Build-Depends: base, network, containers +Build-Depends: base >=3.0.0.0 && <4.2.0.0, network, containers Extensions: ForeignFunctionInterface, EmptyDataDecls Extra-Libraries: adns Includes: "adns.h", "errno.h"