Add DNSUnitTest.hs

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

diff --git a/Network/DNS/Message.hs b/Network/DNS/Message.hs
index 3fc48a59f5470225648278fd5a8ad5aecaf21953..6144d13766e037d551838526f18804bf0b896451 100644 (file)
--- a/Network/DNS/Message.hs
+++ b/Network/DNS/Message.hs
@@ -18,9 +18,13 @@ module Network.DNS.Message
 
     , CNAME(..)
     , HINFO(..)
 
     , CNAME(..)
     , HINFO(..)

+
+    , mkQueryType
+    , mkDomainName

     )
     where
 
     )
     where
 

+import           Control.Exception

 import           Control.Monad
 import           Data.Binary
 import           Data.Binary.BitPut as BP
 import           Control.Monad
 import           Data.Binary
 import           Data.Binary.BitPut as BP


@@ -28,6 +32,7 @@ import           Data.Binary.Get as G
 import           Data.Binary.Put as P
 import           Data.Binary.Strict.BitGet as BG
 import qualified Data.ByteString as BS
 import           Data.Binary.Put as P
 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.Typeable
 import qualified Data.IntMap as IM
 import qualified Data.ByteString.Lazy as LBS
 import           Data.Typeable
 import qualified Data.IntMap as IM


@@ -52,6 +57,7 @@ data Message
       , msgAuthorities :: ![SomeRR]
       , msgAdditionals :: ![SomeRR]
       }
       , msgAuthorities :: ![SomeRR]
       , msgAdditionals :: ![SomeRR]
       }

+    deriving (Show, Eq)

 
 data Header
     = Header {
 
 data Header
     = Header {


@@ -70,6 +76,7 @@ data Header
       -- + NSCOUNT
       -- + ARCOUNT
       }
       -- + NSCOUNT
       -- + ARCOUNT
       }

+    deriving (Show, Eq)

 
 type MessageID = Word16
 
 
 type MessageID = Word16
 


@@ -96,11 +103,16 @@ data ResponseCode
 data Question
     = Question {
         qName  :: !DomainName
 data Question
     = Question {
         qName  :: !DomainName

-      , qType  :: !SomeRT
+      , qType  :: !SomeQT

       , qClass :: !RecordClass
       }
     deriving (Show, Eq)
 
       , qClass :: !RecordClass
       }
     deriving (Show, Eq)
 

+type SomeQT = SomeRT
+
+mkQueryType :: RecordType rt dt => rt -> SomeQT
+mkQueryType = SomeRT
+

 putQ :: Question -> Put
 putQ q
     = do putDomainName $ qName q
 putQ :: Question -> Put
 putQ q
     = do putDomainName $ qName q


@@ -128,6 +140,18 @@ nameToLabels (DN ls) = ls
 labelsToName :: [DomainLabel] -> DomainName
 labelsToName = DN
 
 labelsToName :: [DomainLabel] -> DomainName
 labelsToName = DN
 

+mkDomainName :: String -> DomainName
+mkDomainName = labelsToName . mkLabels [] . notEmpty
+    where
+      notEmpty :: String -> String
+      notEmpty xs = assert (not $ null xs) xs
+
+      mkLabels :: [DomainLabel] -> String -> [DomainLabel]
+      mkLabels soFar [] = reverse (C8.empty : soFar)
+      mkLabels soFar xs = case break (== '.') xs of
+                            (l, ('.':rest))
+                                -> mkLabels (C8.pack l : soFar) rest
+                            _   -> error ("Illegal domain name: " ++ xs)

 
 data RecordClass
     = IN
 
 data RecordClass
     = IN