Add DNSUnitTest.hs

diff --git a/DNSUnitTest.hs b/DNSUnitTest.hs
new file mode 100644 (file)
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 00055ac8e70d1329958589c25e329cd478f61a03..c12ffabc181494581f81824a4e00102211104de8 100644 (file)
--- a/Makefile
+++ b/Makefile
@@ -9,7 +9,7 @@ build: dist/setup-config Setup
 #      $(MAKE) -C examples run
 
 dist/setup-config: $(CABAL_FILE) 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
 
 Setup: Setup.lhs
        $(GHC) --make Setup


@@ -27,4 +27,7 @@ install: build
 sdist: Setup
        ./Setup sdist
 
 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 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

diff --git a/Setup.lhs b/Setup.lhs
index 5bde0de962274e26328ecffabb4e9f6430a10cc9..335aacc692f0b63163d762914dc1a6bc60797a9a 100644 (file)
--- a/Setup.lhs
+++ b/Setup.lhs
@@ -1,3 +1,8 @@
 #!/usr/bin/env runhaskell
 > import Distribution.Simple
 #!/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 1d1c4d699ccd89dabca35f58aeb9ce2c14e96aaa..91c825bcd298ed5abe5cc00ca70abdb5818b1488 100644 (file)
--- 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
 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:
 
 Library
     Build-Depends:


@@ -24,3 +30,23 @@ Library
 
     GHC-Options:
         -Wall
 
     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