AAAA support

[haskell-dns.git] / Network / DNS / Message.hs

diff --git a/Network/DNS/Message.hs b/Network/DNS/Message.hs
index 17c037f7dba99a18a3c4457f670a5aaa017b5a54..db5016096df79dc83788770b21de2aa014d60f1e 100644 (file)
--- a/Network/DNS/Message.hs
+++ b/Network/DNS/Message.hs
@@ -19,10 +19,11 @@ module Network.DNS.Message
     , SOAFields(..)
     , WKSFields(..)
 
-    , SomeQ
-    , SomeRR
+    , SomeQ(..)
+    , SomeRR(..)
 
     , A(..)
+    , AAAA(..)
     , NS(..)
     , MD(..)
     , MF(..)
@@ -50,6 +51,13 @@ module Network.DNS.Message
     , HS(..)
 
     , mkDomainName
+    , rootName
+    , isRootName
+    , consLabel
+    , unconsLabel
+    , nameToLabels
+    , isZoneOf
+
     , wrapQuestion
     , wrapRecord
     )
@@ -65,11 +73,13 @@ import           Data.Binary.Strict.BitGet as BG
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
 import qualified Data.ByteString.Lazy as LBS
+import           Data.String
 import           Data.Typeable
 import qualified Data.IntMap as IM
 import           Data.IntMap (IntMap)
 import qualified Data.IntSet as IS
 import           Data.IntSet (IntSet)
+import           Data.List
 import qualified Data.Map as M
 import           Data.Map (Map)
 import           Data.Word
@@ -210,6 +220,9 @@ getSomeQC = do n <- liftM fromIntegral U.getWord16be
 newtype DomainName  = DN [DomainLabel] deriving (Eq, Show, Ord, Typeable)
 type DomainLabel    = BS.ByteString
 
+instance IsString DomainName where
+    fromString = mkDomainName
+
 rootName :: DomainName
 rootName = DN [BS.empty]
 
@@ -224,6 +237,12 @@ unconsLabel :: DomainName -> (DomainLabel, DomainName)
 unconsLabel (DN (x:xs)) = (x, DN xs)
 unconsLabel x           = error ("Illegal use of unconsLabel: " ++ show x)
 
+nameToLabels :: DomainName -> [DomainLabel]
+nameToLabels (DN xs) = xs
+
+isZoneOf :: DomainName -> DomainName -> Bool
+isZoneOf (DN a) (DN b) = a `isSuffixOf` b
+
 mkDomainName :: String -> DomainName
 mkDomainName = DN . mkLabels [] . notEmpty
     where
@@ -511,6 +530,20 @@ instance RecordType A HostAddress where
     putRecordData _ = P.putWord32be
     getRecordData _ = U.getWord32be
 
+data AAAA = AAAA deriving (Show, Eq, Typeable)
+instance RecordType AAAA HostAddress6 where
+    rtToInt       _ = 28
+    putRecordData _ = \ (a, b, c, d) ->
+                      do P.putWord32be a
+                         P.putWord32be b
+                         P.putWord32be c
+                         P.putWord32be d
+    getRecordData _ = do a <- U.getWord32be
+                         b <- U.getWord32be
+                         c <- U.getWord32be
+                         d <- U.getWord32be
+                         return (a, b, c, d)
+
 data NS = NS deriving (Show, Eq, Typeable)
 instance RecordType NS DomainName where
     rtToInt       _ = 2
@@ -829,6 +862,7 @@ instance Enum ResponseCode where
 defaultRTTable :: IntMap SomeRT
 defaultRTTable = IM.fromList $ map toPair $
                  [ SomeRT A
+                 , SomeRT AAAA
                  , SomeRT NS
                  , SomeRT MD
                  , SomeRT MF
@@ -904,4 +938,4 @@ wrapQuestion :: (QueryType qt, QueryClass qc) => Question qt qc -> SomeQ
 wrapQuestion = SomeQ
 
 wrapRecord :: (RecordType rt dt, RecordClass rc) => ResourceRecord rt rc dt -> SomeRR
-wrapRecord = SomeRR
\ No newline at end of file
+wrapRecord = SomeRR