From 4b50a2b0cb6125db0a4f7c84768b2736b6ac5552 Mon Sep 17 00:00:00 2001
From: Kazu Yamamoto <kazu@iij.ad.jp>
Date: Tue, 6 Sep 2011 16:33:49 +0900
Subject: Supporting SRV.

---
 Network/DNS/Internal.hs |  5 ++++-
 Network/DNS/Lookup.hs   | 13 +++++++++++++
 Network/DNS/Response.hs |  8 ++++++++
 Test.hs                 |  7 +++++++
 4 files changed, 32 insertions(+), 1 deletion(-)

diff --git a/Network/DNS/Internal.hs b/Network/DNS/Internal.hs
index f2dff00..8274afe 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 | PTR
+data TYPE = A | AAAA | NS | TXT | MX | CNAME | SOA | PTR | SRV
           | UNKNOWN Int deriving (Eq, Show, Read)
 
 rrDB :: [(TYPE, Int)]
@@ -31,6 +31,7 @@ rrDB = [
   , (MX,    15)
   , (TXT,   16)
   , (AAAA,  28)
+  , (SRV,   33)
   ]
 
 rookup                  :: (Eq b) => b -> [(a,b)] -> Maybe a
@@ -129,6 +130,7 @@ data ResourceRecord = ResourceRecord {
 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_SRV Int Int Int Domain
            | RD_OTH [Int] deriving (Eq)
 
 instance Show RDATA where
@@ -140,6 +142,7 @@ instance Show RDATA where
   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_SRV pri wei prt dom) = show pri ++ " " ++ show wei ++ " " ++ show prt ++ BS.unpack dom
   show (RD_OTH is) = show is
 
 ----------------------------------------------------------------
diff --git a/Network/DNS/Lookup.hs b/Network/DNS/Lookup.hs
index 728b0c6..b47c0d5 100644
--- a/Network/DNS/Lookup.hs
+++ b/Network/DNS/Lookup.hs
@@ -7,6 +7,7 @@ module Network.DNS.Lookup (
   , lookupMX, lookupAviaMX, lookupAAAAviaMX
   , lookupTXT
   , lookupPTR
+  , lookupSRV
   ) where
 
 import Control.Applicative
@@ -95,3 +96,15 @@ lookupPTR rlv dom = toPTR <$> DNS.lookup rlv dom PTR
     toPTR = maybe Nothing (Just . map unTag)
     unTag (RD_PTR dm) = dm
     unTag _ = error "lookupPTR"
+
+----------------------------------------------------------------
+
+{-|
+  Resolving 'Domain' and its preference by 'SRV'.
+-}
+lookupSRV :: Resolver -> Domain -> IO (Maybe [(Int,Int,Int,Domain)])
+lookupSRV rlv dom = toSRV <$> DNS.lookup rlv dom SRV
+  where
+    toSRV = maybe Nothing (Just . map unTag)
+    unTag (RD_SRV pri wei prt dm) = (pri,wei,prt,dm)
+    unTag _ = error "lookupSRV"
diff --git a/Network/DNS/Response.hs b/Network/DNS/Response.hs
index fdce3e3..36f6203 100644
--- a/Network/DNS/Response.hs
+++ b/Network/DNS/Response.hs
@@ -127,6 +127,14 @@ decodeRData SOA _ = RD_SOA <$> decodeDomain
     decodeExpire  = getInt32
     decodeMinumun = getInt32
 decodeRData PTR _ = RD_PTR <$> decodeDomain
+decodeRData SRV _ = RD_SRV <$> decodePriority
+                           <*> decodeWeight
+                           <*> decodePort
+                           <*> decodeDomain
+  where
+    decodePriority = getInt16
+    decodeWeight   = getInt16
+    decodePort     = getInt16
 
 decodeRData _  len = RD_OTH <$> getNBytes len
 
diff --git a/Test.hs b/Test.hs
index efe7e4b..4a9cdfe 100644
--- a/Test.hs
+++ b/Test.hs
@@ -18,6 +18,7 @@ tests = [
        , testCase "lookupAviaMX" test_lookupAviaMX
        , testCase "lookupAviaCNAME" test_lookupAviaCNAME
        , testCase "lookupPTR" test_lookupPTR
+       , testCase "lookupSRV" test_lookupSRV
        ]
   ]
 
@@ -72,5 +73,11 @@ test_lookupPTR = do
     rev = BS.intercalate "." (reverse (BS.split '.' target))
           `BS.append` ".in-addr.arpa"
 
+test_lookupSRV :: IO ()
+test_lookupSRV = do
+    rs <- makeResolvSeed defaultResolvConf
+    withResolver rs $ \resolver ->
+        DNS.lookupSRV resolver "_sip._tcp.cisco.com" ?= Just [(1,0,5060,"vcsgw.cisco.com.")]
+
 main :: IO ()
 main = defaultMain tests
-- 
cgit v1.2.3