diff options
author | Kazu Yamamoto <kazu@iij.ad.jp> | 2010-03-24 12:03:28 +0900 |
---|---|---|
committer | Kazu Yamamoto <kazu@iij.ad.jp> | 2010-03-24 12:03:28 +0900 |
commit | 4371090def28793aa2fdf33fb7432a959ba214fa (patch) | |
tree | 3d47f12214b40635dc62fc69fed5f2c1b64da644 /Network | |
parent | c2bd3b127be27a40cb279fb82d16cff147aaa10e (diff) |
implementing lookupXviaMX
Diffstat (limited to 'Network')
-rw-r--r-- | Network/DNS.hs | 2 | ||||
-rw-r--r-- | Network/DNS/Lookup.hs | 57 | ||||
-rw-r--r-- | Network/DNS/Resolver.hs | 5 |
3 files changed, 60 insertions, 4 deletions
diff --git a/Network/DNS.hs b/Network/DNS.hs index db03c2d..735db1f 100644 --- a/Network/DNS.hs +++ b/Network/DNS.hs @@ -1,5 +1,5 @@ {-| - DNS library written in Haskell. + Thread-safe DNS library written in Haskell. Currently, only resolver side is supported. This code is written in Haskell, not using FFI. So, the \"-threaded\" option for GHC is not diff --git a/Network/DNS/Lookup.hs b/Network/DNS/Lookup.hs index c458149..ad0da4d 100644 --- a/Network/DNS/Lookup.hs +++ b/Network/DNS/Lookup.hs @@ -1,10 +1,24 @@ -module Network.DNS.Lookup where +{-| + Upper level DNS lookup functions. +-} + +module Network.DNS.Lookup ( + lookupA, lookupAAAA + , lookupMX, lookupAviaMX, lookupAAAAviaMX + , lookupTXT + ) where import Control.Applicative import Data.IP +import Data.Maybe import Network.DNS.Types import Network.DNS.Resolver as DNS +---------------------------------------------------------------- + +{-| + Resolving 'IPv4' by 'A'. +-} lookupA :: Resolver -> Domain -> IO (Maybe [IPv4]) lookupA rlv dom = toV4 <$> DNS.lookup rlv dom A where @@ -12,6 +26,9 @@ lookupA rlv dom = toV4 <$> DNS.lookup rlv dom A unTag (RD_A x) = x unTag _ = error "lookupA" +{-| + Resolving 'IPv6' by 'AAAA'. +-} lookupAAAA :: Resolver -> Domain -> IO (Maybe [IPv6]) lookupAAAA rlv dom = toV6 <$> DNS.lookup rlv dom AAAA where @@ -19,12 +36,46 @@ lookupAAAA rlv dom = toV6 <$> DNS.lookup rlv dom AAAA unTag (RD_AAAA x) = x unTag _ = error "lookupAAAA" +---------------------------------------------------------------- + +{-| + Resolving 'Domain' and its preference by 'MX'. +-} +lookupMX :: Resolver -> Domain -> IO (Maybe [(Domain,Int)]) +lookupMX rlv dom = toMX <$> DNS.lookup rlv dom MX + where + toMX = maybe Nothing (Just . map unTag) + unTag (RD_MX pr dm) = (dm,pr) + unTag _ = error "lookupMX" + +{-| + Resolving 'IPv4' by 'A' via 'MX'. +-} lookupAviaMX :: Resolver -> Domain -> IO (Maybe [IPv4]) -lookupAviaMX = undefined +lookupAviaMX rlv dom = lookupXviaMX rlv dom (lookupA rlv) +{-| + Resolving 'IPv6' by 'AAAA' via 'MX'. +-} lookupAAAAviaMX :: Resolver -> Domain -> IO (Maybe [IPv6]) -lookupAAAAviaMX = undefined +lookupAAAAviaMX rlv dom = lookupXviaMX rlv dom (lookupAAAA rlv) + +lookupXviaMX :: Resolver -> Domain -> (Domain -> IO (Maybe [a])) -> IO (Maybe [a]) +lookupXviaMX rlv dom func = do + mdps <- lookupMX rlv dom + maybe (return Nothing) lookup' mdps + where + lookup' dps = do + as <- catMaybes <$> mapM func (map fst dps) + case as of + [] -> return Nothing + ass -> return $ Just (concat ass) + +---------------------------------------------------------------- +{-| + Resolving 'String' by 'TXT'. +-} lookupTXT :: Resolver -> Domain -> IO (Maybe [String]) lookupTXT rlv dom = toTXT <$> DNS.lookup rlv dom TXT where diff --git a/Network/DNS/Resolver.hs b/Network/DNS/Resolver.hs index e959bcb..54a6411 100644 --- a/Network/DNS/Resolver.hs +++ b/Network/DNS/Resolver.hs @@ -78,6 +78,11 @@ makeAddrInfo addr = do ---------------------------------------------------------------- +{-| + Giving a thread-safe 'Resolver' to the function of the second + argument. 'withResolver' should be passed to 'forkIO'. +-} + withResolver :: ResolvSeed -> (Resolver -> IO ()) -> IO () withResolver seed func = do let ai = addrInfo seed |