From 8e28329b12d1cabd0038e5d86c8c8edd9dfe0e5e Mon Sep 17 00:00:00 2001
From: Kazu Yamamoto <kazu@iij.ad.jp>
Date: Mon, 5 Sep 2011 16:06:17 +0900
Subject: Supporting PTR.

---
 Network/DNS/Internal.hs |  6 ++++--
 Network/DNS/Lookup.hs   | 13 +++++++++++++
 Network/DNS/Response.hs |  1 +
 Test.hs                 | 12 ++++++++++++
 4 files changed, 30 insertions(+), 2 deletions(-)

diff --git a/Network/DNS/Internal.hs b/Network/DNS/Internal.hs
index 28063fc..f2dff00 100644
--- a/Network/DNS/Internal.hs
+++ b/Network/DNS/Internal.hs
@@ -18,7 +18,7 @@ type Domain = ByteString
 {-|
   Types for resource records.
 -}
-data TYPE = A | AAAA | NS | TXT | MX | CNAME | SOA
+data TYPE = A | AAAA | NS | TXT | MX | CNAME | SOA | PTR
           | UNKNOWN Int deriving (Eq, Show, Read)
 
 rrDB :: [(TYPE, Int)]
@@ -27,6 +27,7 @@ rrDB = [
   , (NS,     2)
   , (CNAME,  5)
   , (SOA,    6)
+  , (PTR,   12)
   , (MX,    15)
   , (TXT,   16)
   , (AAAA,  28)
@@ -125,7 +126,7 @@ data ResourceRecord = ResourceRecord {
 {-|
   Raw data format for each type.
 -}
-data RDATA = RD_NS Domain | RD_CNAME Domain | RD_MX Int Domain
+data RDATA = RD_NS Domain | RD_CNAME Domain | RD_MX Int Domain | RD_PTR Domain
            | RD_SOA Domain Domain Int Int Int Int Int
            | RD_A IPv4 | RD_AAAA IPv6 | RD_TXT ByteString
            | RD_OTH [Int] deriving (Eq)
@@ -138,6 +139,7 @@ instance Show RDATA where
   show (RD_AAAA aaaa) = show aaaa
   show (RD_TXT txt) = BS.unpack txt
   show (RD_SOA mn _ _ _ _ _ mi) = BS.unpack mn ++ " " ++ show mi
+  show (RD_PTR dom) = BS.unpack dom
   show (RD_OTH is) = show is
 
 ----------------------------------------------------------------
diff --git a/Network/DNS/Lookup.hs b/Network/DNS/Lookup.hs
index 79af339..728b0c6 100644
--- a/Network/DNS/Lookup.hs
+++ b/Network/DNS/Lookup.hs
@@ -6,6 +6,7 @@ module Network.DNS.Lookup (
     lookupA, lookupAAAA
   , lookupMX, lookupAviaMX, lookupAAAAviaMX
   , lookupTXT
+  , lookupPTR
   ) where
 
 import Control.Applicative
@@ -82,3 +83,15 @@ lookupTXT rlv dom = toTXT <$> DNS.lookup rlv dom TXT
     toTXT = maybe Nothing (Just . map unTag)
     unTag (RD_TXT x) = x
     unTag _ = error "lookupTXT"
+
+----------------------------------------------------------------
+
+{-|
+  Resolving 'Domain' and its preference by 'PTR'.
+-}
+lookupPTR :: Resolver -> Domain -> IO (Maybe [Domain])
+lookupPTR rlv dom = toPTR <$> DNS.lookup rlv dom PTR
+  where
+    toPTR = maybe Nothing (Just . map unTag)
+    unTag (RD_PTR dm) = dm
+    unTag _ = error "lookupPTR"
diff --git a/Network/DNS/Response.hs b/Network/DNS/Response.hs
index d746fc2..fdce3e3 100644
--- a/Network/DNS/Response.hs
+++ b/Network/DNS/Response.hs
@@ -126,6 +126,7 @@ decodeRData SOA _ = RD_SOA <$> decodeDomain
     decodeRetry   = getInt32
     decodeExpire  = getInt32
     decodeMinumun = getInt32
+decodeRData PTR _ = RD_PTR <$> decodeDomain
 
 decodeRData _  len = RD_OTH <$> getNBytes len
 
diff --git a/Test.hs b/Test.hs
index 5b6a916..efe7e4b 100644
--- a/Test.hs
+++ b/Test.hs
@@ -7,6 +7,7 @@ import Network.DNS as DNS
 import Test.Framework (defaultMain, testGroup, Test)
 import Test.Framework.Providers.HUnit
 import Test.HUnit hiding (Test)
+import qualified Data.ByteString.Char8 as BS
 
 tests :: [Test]
 tests = [
@@ -16,6 +17,7 @@ tests = [
        , testCase "lookupTXT" test_lookupTXT
        , testCase "lookupAviaMX" test_lookupAviaMX
        , testCase "lookupAviaCNAME" test_lookupAviaCNAME
+       , testCase "lookupPTR" test_lookupPTR
        ]
   ]
 
@@ -60,5 +62,15 @@ test_lookupAviaCNAME = do
     withResolver rs $ \resolver ->
         DNS.lookupA resolver "ghs.google.com" ??= ["72.14.203.121"]
 
+test_lookupPTR :: IO ()
+test_lookupPTR = do
+    rs <- makeResolvSeed defaultResolvConf
+    withResolver rs $ \resolver ->
+        DNS.lookupPTR resolver rev ?= Just ["www-v4.iij.ad.jp."]
+  where
+    target = "210.130.137.80"
+    rev = BS.intercalate "." (reverse (BS.split '.' target))
+          `BS.append` ".in-addr.arpa"
+
 main :: IO ()
 main = defaultMain tests
-- 
cgit v1.2.3