AAAA support

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

diff --git a/Network/DNS/Message.hs b/Network/DNS/Message.hs
index 9713dd2a707ed66d8776458733401346d7eb2e72..db5016096df79dc83788770b21de2aa014d60f1e 100644 (file)
--- a/Network/DNS/Message.hs
+++ b/Network/DNS/Message.hs
@@ -23,6 +23,7 @@ module Network.DNS.Message
     , SomeRR(..)
 
     , A(..)
+    , AAAA(..)
     , NS(..)
     , MD(..)
     , MF(..)
@@ -50,7 +51,6 @@ module Network.DNS.Message
     , HS(..)
 
     , mkDomainName
-    , mkDN
     , rootName
     , isRootName
     , consLabel
@@ -73,6 +73,7 @@ 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)
@@ -219,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]
 
@@ -252,9 +256,6 @@ mkDomainName = DN . mkLabels [] . notEmpty
                                 -> mkLabels (C8.pack l : soFar) rest
                             _   -> error ("Illegal domain name: " ++ xs)
 
-mkDN :: String -> DomainName
-mkDN = mkDomainName
-
 
 class (Show rc, Eq rc, Typeable rc) => RecordClass rc where
     rcToInt :: rc -> Int
@@ -529,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
@@ -847,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