From d4d887202f59a0bb394d04e74c2f02eb91e26f5f Mon Sep 17 00:00:00 2001 From: PHO Date: Thu, 21 May 2009 15:20:26 +0900 Subject: [PATCH] Add DNSUnitTest.hs --- DNSUnitTest.hs | 46 ++++++++++++++++++++++++++++++++++++++++++ Makefile | 7 +++++-- Network/DNS/Message.hs | 26 +++++++++++++++++++++++- Setup.lhs | 7 ++++++- dns.cabal | 26 ++++++++++++++++++++++++ 5 files changed, 108 insertions(+), 4 deletions(-) create mode 100644 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 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 -- 2.40.0