-------------------------------------------------------------------------------- -- $Id: URITestRunner.hs,v 1.1 2004/04/21 12:43:26 graham Exp $ -- -- Copyright (c) 2004, G. KLYNE. All rights reserved. -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : URITest -- Copyright : (c) 2004, Graham Klyne -- License : BSD-style (see end of this file) -- -- Maintainer : Graham Klyne -- Stability : provisional -- Portability : H98 -- -- This program constructs and executes URI test cases described in a -- file UriTest.n3. (See also the files UriTest.xls and UriTest.csv from -- which the desc description file is derived.) -- -------------------------------------------------------------------------------- module URITest where import Network.URI ( URI(..), URIAuth(..) , parseURI , isUri, isUriReference, isRelativeUri, isAbsoluteUri , isIPv6address, isIPv4address , relativeTo , relativeFrom , normalizeCase, normalizeEscape, normalizePathSegments ) import SwishCommands ( swishReadGraph ) import SwishMonad ( SwishStateIO, SwishState(..) , setFormat, setGraph , modGraphs, modRulesets , setInfo, resetInfo, setError, resetError, setExitcode , emptyState , SwishFormat(..) , swishError , reportLines, reportLine ) import RDFRuleset ( makeRDFGraphFromN3String ) import RDFQuery ( rdfQueryFind, rdfQueryMore, rdfQueryFilter ) import RDFVarBinding ( RDFVarBinding, nullRDFVarBinding ) import VarBinding ( VarBinding(..) ) import RDFGraph ( Label(..), Arc(..), LDGraph(..) , RDFLabel(..), getLiteralText , RDFGraph, emptyRDFGraph ) import HUnit import ListHelpers ( breakAll, flist ) import Control.Monad.Trans ( MonadTrans(..), liftIO ) import Control.Monad.State ( MonadState(..), modify, StateT(..), execStateT ) import Data.Char ( isSpace ) import Monad ( when ) import IO ( Handle, openFile, IOMode(WriteMode), hClose, hPutStr, hPutStrLn ) import System ( getArgs, ExitCode(ExitSuccess,ExitFailure), exitWith ) import Maybe ( fromMaybe ) -- Parser tests data URIType = AbsId -- URI form (absolute, no fragment) | AbsRf -- Absolute URI reference | RelRf -- Relative URI reference | InvRf -- Invalid URI reference isValidT :: URIType -> Bool isValidT InvRf = False isValidT _ = True isAbsRfT :: URIType -> Bool isAbsRfT AbsId = True isAbsRfT AbsRf = True isAbsRfT _ = False isRelRfT :: URIType -> Bool isRelRfT RelRf = True isRelRfT _ = False isAbsIdT :: URIType -> Bool isAbsIdT AbsId = True isAbsIdT _ = False testEq :: (Eq a, Show a) => String -> a -> a -> Test testEq lab a1 a2 = TestCase ( assertEqual lab a1 a2 ) type TestUri = String -> String -> Test testURIRef :: URIType -> String -> String -> Test testURIRef t lab u = TestList [ testEq (lab++"(isUri):"++u) (isValidT t) (isUriReference u) , testEq (lab++"(isRel):"++u) (isRelRfT t) (isRelativeUri u) , testEq (lab++"(isAbs):"++u) (isAbsIdT t) (isAbsoluteUri u) ] testURIRefComponents :: String -> (Maybe URI) -> String -> Test testURIRefComponents lab uv us = testEq ("testURIRefComponents:"++us) uv (parseURI us) -- Get reference relative to given base, and reconstruct absolute URI -- from base and relative reference. -- -- NOTE: absoluteURI base (relativeRef base u) is always equivalent to u. -- cf. http://lists.w3.org/Archives/Public/uri/2003Jan/0008.html type TestRel = String -> String -> String -> String -> Test testRelSplit :: String -> String -> String -> String -> Test testRelSplit label base uabs urel = testEq label urel (mkrel puabs pubas) where mkrel (Just u1) (Just u2) = show (u1 `relativeFrom` u2) mkrel Nothing _ = "Invalid URI: "++urel mkrel _ Nothing = "Invalid URI: "++uabs puabs = parseURI uabs pubas = parseURI base testRelJoin :: String -> String -> String -> String -> Test testRelJoin label base uabs urel = testEq label uabs (mkabs purel pubas) where mkabs (Just u1) (Just u2) = shabs (u1 `relativeTo` u2) mkabs Nothing _ = "Invalid URI: "++urel mkabs _ Nothing = "Invalid URI: "++uabs shabs (Just u) = show u shabs Nothing = "No result" purel = parseURI urel pubas = parseURI base testRelative :: String -> String -> String -> String -> Test testRelative label base uabs urel = TestList [ (testRelSplit (label++"(toRel)") base uabs urel), (testRelJoin (label++"(toAbs)") base uabs urel) ] -- Normalization tests type TestNorm = String -> String -> String -> Test testNormalize :: (String -> String) -> String -> String -> String -> Test testNormalize fnorm label ures uinp = testEq label ures (fnorm uinp) testNormalizeCase :: String -> String -> String -> Test testNormalizeCase = testNormalize normalizeCase testNormalizeEsc :: String -> String -> String -> Test testNormalizeEsc = testNormalize normalizeEscape testNormalizePath :: String -> String -> String -> Test testNormalizePath = testNormalize normalizePathSegments -- Build test cases: returns a list of test cases constructed based -- on descriptions in the supplied RDF graph. buildTestCases :: RDFGraph -> [Test] buildTestCases = map buildTestCase . find where find :: RDFGraph -> [TestDescription] find = concat . flist testQueries testQueries = [ qAbsRf, qAbsId, qRelRf, qInvRf , qDecomp , qRelative, qRel2Abs, qAbs2Rel , qNormCase, qNormEsc, qNormPath ] data TestDescription = UriTestSyntax { turi::TestUri, vbind::RDFVarBinding } | UriTestDecomp { vbind::RDFVarBinding } | UriTestRelative { trel::TestRel, vbind::RDFVarBinding } | UriTestNormalize { tnorm::TestNorm, vbind::RDFVarBinding } commonPrefix = concatMap (++"\n") [ "@prefix rdf: ." , "@prefix rdfs: ." , "@prefix xsd: ." , "@prefix uri: ." ] buildTestCase :: TestDescription -> Test buildTestCase td = case td of UriTestSyntax tUri vb -> tUri tlab base UriTestDecomp vb -> testURIRefComponents tlab uval base UriTestRelative tRel vb -> tRel tlab base uabs urel UriTestNormalize tNorm vb -> tNorm tlab base uabs where getText v = getLiteralText $ fromMaybe NoNode (vbMap (vbind td) (Var v)) tlab = getText "l" base = getText "b" uabs = getText "a" urel = getText "r" uval = if null usch then Nothing else Just $ URI usch auth path query frag usch = getText "us" path = getText "up" query = getText "uq" frag = getText "uf" auth = case take 1 (getText "ua") of "T" -> Just $ URIAuth auser areg aport otherwise -> Nothing auser = getText "au" areg = getText "ar" aport = getText "ap" -- Construct syntax checking test descriptions qAbsRf :: RDFGraph -> [TestDescription] qAbsRf = qSyntax "uri:AbsRf" (testURIRef AbsRf) qAbsId :: RDFGraph -> [TestDescription] qAbsId = qSyntax "uri:AbsId" (testURIRef AbsId) qRelRf :: RDFGraph -> [TestDescription] qRelRf = qSyntax "uri:RelRf" (testURIRef RelRf) qInvRf :: RDFGraph -> [TestDescription] qInvRf = qSyntax "uri:InvRf" (testURIRef InvRf) qSyntax :: String -> TestUri -> RDFGraph -> [TestDescription] qSyntax testnam testtyp = queryTest (UriTestSyntax testtyp) ( concat [ commonPrefix , " ?t rdf:type uri:UriTest ;" , " rdfs:label ?l ;" , " uri:test ", testnam, " ;" , " uri:base ?b . " ] ) [ commonPrefix++" ?t rdfs:comment ?c . " ] -- Construct URI decomposition test description qDecomp = queryTest UriTestDecomp ( concat [ commonPrefix , " ?t rdf:type uri:UriTest ;" , " rdfs:label ?l ;" , " uri:test uri:Decomp ;" , " uri:base ?b . " ] ) [ commonPrefix++" ?t uri:scheme ?us . " , commonPrefix++" ?t uri:auth ?ua . " , commonPrefix++" ?t uri:user ?au . " , commonPrefix++" ?t uri:reg ?ar . " , commonPrefix++" ?t uri:port ?ap . " , commonPrefix++" ?t uri:path ?up . " , commonPrefix++" ?t uri:query ?uq . " , commonPrefix++" ?t uri:frag ?uf . " ] -- Construct relative-URI handling test descriptions qRelative :: RDFGraph -> [TestDescription] qRelative = qRelUri "uri:Relative" testRelative qRel2Abs :: RDFGraph -> [TestDescription] qRel2Abs = qRelUri "uri:Rel2Abs" testRelJoin qAbs2Rel :: RDFGraph -> [TestDescription] qAbs2Rel = qRelUri "uri:Abs2Rel" testRelSplit qRelUri :: String -> TestRel -> RDFGraph -> [TestDescription] qRelUri testnam testtyp = queryTest (UriTestRelative testtyp) ( concat [ commonPrefix , " ?t rdf:type uri:UriTest ;" , " rdfs:label ?l ;" , " uri:test ", testnam, " ;" , " uri:base ?b ; " , " uri:abs ?a ; " , " uri:rel ?r . " ] ) [ commonPrefix++" ?t rdfs:comment ?c . " ] -- Construct URI normalization test descriptions qNormCase :: RDFGraph -> [TestDescription] qNormCase = qNormalize "uri:NormCase" testNormalizeCase qNormEsc :: RDFGraph -> [TestDescription] qNormEsc = qNormalize "uri:NormEsc" testNormalizeEsc qNormPath :: RDFGraph -> [TestDescription] qNormPath = qNormalize "uri:NormPath" testNormalizePath qNormalize :: String -> TestNorm -> RDFGraph -> [TestDescription] qNormalize testnam testtyp = queryTest (UriTestNormalize testtyp) ( concat [ commonPrefix , " ?t rdf:type uri:UriTest ;" , " rdfs:label ?l ;" , " uri:test ", testnam, " ;" , " uri:base ?b ; " , " uri:abs ?a . " ] ) [ commonPrefix++" ?t rdfs:comment ?c . " ] -- |Generic graph query function returning a list of test descriptions -- -- maketd is a function that turns a query binding into a test -- description, and which may incorporate separate knowledge -- of the test into the result. -- query is a query graph, each of whose matches corresponds to -- a single test description to be returned. -- quopt is a list of additional queries that may be used to -- extract optional additional information about the test. -- When matched, additional variable bindings are craeted, -- otherwise they are ignored. -- inputgr is the graph containing test information from which test -- descriptions are extracted. -- queryTest :: (RDFVarBinding -> TestDescription) -> String -> [String] -> RDFGraph -> [TestDescription] queryTest maketd query quopt inputgr = map maketd queryres where querygr = makeRDFGraphFromN3String query quoptgr = map makeRDFGraphFromN3String quopt queryreq = rdfQueryFind querygr inputgr queryres = concatMap (queryopt quoptgr) queryreq -- Now match optional query graphs queryopt [] vb = [vb] queryopt (qg:qgs) vb = concatMap (queryopt qgs) v2 where v1 = rdfQueryMore vb qg inputgr v2 = if null v1 then [vb] else v1 -- Main program: read test descriptions, construct and run tests main :: IO () main = do { args <- getArgs ; code <- runUriTestsArgs args ; if code == ExitSuccess then return () else putStrLn $ "URITestRunner: "++show code ; exitWith code } runUriTests :: String -> IO ExitCode runUriTests cmdline = do { let args = breakAll isSpace cmdline ; ec <- runUriTestsArgs args ; when (ec /= ExitSuccess) (putStrLn $ "URITestRunner exit: "++show ec) ; return ec } runUriTestsArgs :: [String] -> IO ExitCode runUriTestsArgs args = do { state <- execStateT (uriTestRunner args) emptyState ; return $ exitcode state } uriTestRunner :: [String] -> SwishStateIO () uriTestRunner args = do { maybegraph <- swishReadGraph "UriTest.n3" ; case maybegraph of Just gr -> do { let ts = buildTestCases gr ; let tm = TestList ts ; let tr = runTestTT ; cts <- liftIO (tr tm) ; return () } Nothing -> swishError "Failed to read test descriptions" 2 } runTestFile t = do h <- openFile "a.tmp" WriteMode runTestText (putTextToHandle h False) t hClose h tf = runTestFile tt = runTestTT -------------------------------------------------------------------------------- -- -- Copyright (c) 2004, G. KLYNE. All rights reserved. -- Distributed as free software under the following license. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions -- are met: -- -- - Redistributions of source code must retain the above copyright notice, -- this list of conditions and the following disclaimer. -- -- - Redistributions in binary form must reproduce the above copyright -- notice, this list of conditions and the following disclaimer in the -- documentation and/or other materials provided with the distribution. -- -- - Neither name of the copyright holders nor the names of its -- contributors may be used to endorse or promote products derived from -- this software without specific prior written permission. -- -- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE CONTRIBUTORS -- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -- HOLDERS OR THE CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, -- INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, -- BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS -- OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND -- ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR -- TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE -- USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- -------------------------------------------------------------------------------- -- $Source: /file/cvsdev/HaskellUtils/Network/URITestRunner.hs,v $ -- $Author: graham $ -- $Revision: 1.1 $ -- $Log: URITestRunner.hs,v $ -- Revision 1.1 2004/04/21 12:43:26 graham -- Update URI test cases spreadsheet. -- Create RDF-driven URI test suite runner. --