AAAA support

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

diff --git a/Network/DNS/Message.hs b/Network/DNS/Message.hs
index fe595b4942e66686b17003eda1aa1ce4c9426577..db5016096df79dc83788770b21de2aa014d60f1e 100644 (file)
--- a/Network/DNS/Message.hs
+++ b/Network/DNS/Message.hs
@@ -23,6 +23,7 @@ module Network.DNS.Message
     , SomeRR(..)
 
     , A(..)
     , SomeRR(..)
 
     , A(..)

+    , AAAA(..)

     , NS(..)
     , MD(..)
     , MF(..)
     , NS(..)
     , MD(..)
     , MF(..)


@@ -50,6 +51,13 @@ module Network.DNS.Message
     , HS(..)
 
     , mkDomainName
     , HS(..)
 
     , mkDomainName

+    , rootName
+    , isRootName
+    , consLabel
+    , unconsLabel
+    , nameToLabels
+    , isZoneOf
+

     , wrapQuestion
     , wrapRecord
     )
     , 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 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.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
 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
 
 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]
 
 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)
 
 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
 mkDomainName :: String -> DomainName
 mkDomainName = DN . mkLabels [] . notEmpty
     where


@@ -511,6 +530,20 @@ instance RecordType A HostAddress where
     putRecordData _ = P.putWord32be
     getRecordData _ = U.getWord32be
 
     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
 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
 defaultRTTable :: IntMap SomeRT
 defaultRTTable = IM.fromList $ map toPair $
                  [ SomeRT A

+                 , SomeRT AAAA

                  , SomeRT NS
                  , SomeRT MD
                  , SomeRT MF
                  , SomeRT NS
                  , SomeRT MD
                  , SomeRT MF