From: PHO <pho@cielonegro.org>
Date: Thu, 21 May 2009 06:20:26 +0000 (+0900)
Subject: Add DNSUnitTest.hs
X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=d4d887202f59a0bb394d04e74c2f02eb91e26f5f;p=haskell-dns.git

Add DNSUnitTest.hs
---

diff --git a/DNSUnitTest.hs b/DNSUnitTest.hs
new file mode 100644
index 0000000..b388345
--- /dev/null
+++ b/DNSUnitTest.hs
@@ -0,0 +1,46 @@
+import           Data.Binary
+import qualified Data.ByteString.Lazy as LBS
+import           Data.Word
+import           Network.DNS.Message
+import           Test.HUnit
+
+
+parseMsg :: [Word8] -> Message
+parseMsg = decode . LBS.pack
+
+
+testData :: [Test]
+testData = [ (parseMsg [ 0x22, 0x79, 0x01, 0x00, 0x00, 0x01, 0x00, 0x00
+                       , 0x00, 0x00, 0x00, 0x00, 0x04, 0x6D, 0x61, 0x69
+                       , 0x6C, 0x0A, 0x63, 0x69, 0x65, 0x6C, 0x6F, 0x6E
+                       , 0x65, 0x67, 0x72, 0x6F, 0x03, 0x6F, 0x72, 0x67
+                       , 0x00, 0x00, 0x05, 0x00, 0x01
+                       ]
+              ~?=
+              Message {
+                msgHeader = Header {
+                              hdMessageID             = 8825
+                            , hdMessageType           = Query
+                            , hdOpcode                = StandardQuery
+                            , hdIsAuthoritativeAnswer = False
+                            , hdIsTruncated           = False
+                            , hdIsRecursionDesired    = True
+                            , hdIsRecursionAvailable  = False
+                            , hdResponseCode          = NoError
+                            }
+              , msgQuestions   = [ Question {
+                                     qName  = mkDomainName "mail.cielonegro.org."
+                                   , qType  = mkQueryType CNAME
+                                   , qClass = IN
+                                   }
+                                 ]
+              , msgAnswers     = []
+              , msgAuthorities = []
+              , msgAdditionals = []
+              }
+             )
+           ]
+
+
+main :: IO ()
+main = runTestTT (test testData) >> return ()
\ No newline at end of file
diff --git a/Makefile b/Makefile
index 00055ac..c12ffab 100644
--- a/Makefile
+++ b/Makefile
@@ -9,7 +9,7 @@ build: dist/setup-config Setup
 #	$(MAKE) -C examples run
 
 dist/setup-config: $(CABAL_FILE) Setup
-	./Setup configure
+	./Setup configure --disable-optimization -fbuild-test-suite
 
 Setup: Setup.lhs
 	$(GHC) --make Setup
@@ -27,4 +27,7 @@ install: build
 sdist: Setup
 	./Setup sdist
 
-.PHONY: build run clean install doc sdist
+test: build
+	./Setup test
+
+.PHONY: build run clean install doc sdist test
diff --git a/Network/DNS/Message.hs b/Network/DNS/Message.hs
index 3fc48a5..6144d13 100644
--- a/Network/DNS/Message.hs
+++ b/Network/DNS/Message.hs
@@ -18,9 +18,13 @@ module Network.DNS.Message
 
     , CNAME(..)
     , HINFO(..)
+
+    , mkQueryType
+    , mkDomainName
     )
     where
 
+import           Control.Exception
 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 qualified Data.ByteString.Char8 as C8 hiding (ByteString)
 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]
       }
+    deriving (Show, Eq)
 
 data Header
     = Header {
@@ -70,6 +76,7 @@ data Header
       -- + NSCOUNT
       -- + ARCOUNT
       }
+    deriving (Show, Eq)
 
 type MessageID = Word16
 
@@ -96,11 +103,16 @@ data ResponseCode
 data Question
     = Question {
         qName  :: !DomainName
-      , qType  :: !SomeRT
+      , qType  :: !SomeQT
       , 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
@@ -128,6 +140,18 @@ nameToLabels (DN ls) = ls
 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
diff --git a/Setup.lhs b/Setup.lhs
index 5bde0de..335aacc 100644
--- a/Setup.lhs
+++ b/Setup.lhs
@@ -1,3 +1,8 @@
 #!/usr/bin/env runhaskell
 > import Distribution.Simple
-> main = defaultMain
+> import System.Cmd
+> import System.Exit
+> main = defaultMainWithHooks (defaultUserHooks { runTests = runTestUnit })
+>     where
+>       runTestUnit _ _ _ _
+>           = system "./dist/build/DNSUnitTest/DNSUnitTest" >> return ()
diff --git a/dns.cabal b/dns.cabal
index 1d1c4d6..91c825b 100644
--- a/dns.cabal
+++ b/dns.cabal
@@ -9,6 +9,12 @@ Maintainer:          PHO <pho at cielonegro.org>
 Stability:           Experimental
 Cabal-Version:       >= 1.2
 Build-Type:          Simple
+Extra-Source-Files:
+    DNSUnitTest.hs
+
+Flag build-test-suite
+    Description: Build the test suite.
+    Default:     False
 
 Library
     Build-Depends:
@@ -24,3 +30,23 @@ Library
 
     GHC-Options:
         -Wall
+
+Executable DNSUnitTest
+    if flag(build-test-suite)
+        Buildable: True
+    else
+        Buildable: False
+
+    Build-Depends:
+        HUnit
+
+    Main-Is:
+        DNSUnitTest.hs
+
+    Extensions:
+        DeriveDataTypeable, ExistentialQuantification,
+        FlexibleInstances, FunctionalDependencies, MultiParamTypeClasses,
+        ScopedTypeVariables
+
+    GHC-Options:
+        -Wall