diff --git a/Setup.lhs b/Setup.lhs index 06e2708f..d9014a88 100755 --- a/Setup.lhs +++ b/Setup.lhs @@ -2,6 +2,10 @@ > module Main where > import Distribution.Simple +> import System.Cmd (system) > main :: IO () -> main = defaultMain +> main = defaultMainWithHooks (simpleUserHooks { runTests = runTests' }) + +> runTests' :: a -> b -> c -> d -> IO () +> runTests' _ _ _ _ = system "runhaskell Test.hs" >> return () diff --git a/Test.hs b/Test.hs new file mode 100644 index 00000000..3ca5e328 --- /dev/null +++ b/Test.hs @@ -0,0 +1,11 @@ +import Test.Framework (defaultMain) + +import qualified Web.Restful.Response +import qualified Web.Restful.Utils +import qualified Web.Restful.Resource + +main = defaultMain + [ Web.Restful.Response.testSuite + , Web.Restful.Utils.testSuite + , Web.Restful.Resource.testSuite + ] diff --git a/Web/Restful.hs b/Web/Restful.hs index 47ac2fbc..1f591eb4 100644 --- a/Web/Restful.hs +++ b/Web/Restful.hs @@ -24,8 +24,8 @@ module Web.Restful import Data.Object import Web.Restful.Request -import Web.Restful.Response +import Web.Restful.Response hiding (testSuite) import Web.Restful.Application import Web.Restful.Definitions import Web.Restful.Handler -import Web.Restful.Resource +import Web.Restful.Resource hiding (testSuite) diff --git a/Web/Restful/Application.hs b/Web/Restful/Application.hs index 8236b97a..6903b3f2 100644 --- a/Web/Restful/Application.hs +++ b/Web/Restful/Application.hs @@ -83,6 +83,7 @@ toHackApp :: RestfulApp resourceName modelType => resourceName -> IO Hack.Application toHackApp a = do + checkResourceName a -- FIXME maybe this should be done compile-time? model <- getModel a key <- encryptKey a let handlers = getHandler model diff --git a/Web/Restful/Request.hs b/Web/Restful/Request.hs index 30a13770..6a8d9ee4 100644 --- a/Web/Restful/Request.hs +++ b/Web/Restful/Request.hs @@ -212,8 +212,6 @@ data RawRequest = RawRequest } deriving Show -deriving instance Show FileInfo - -- | All GET paramater values with the given name. getParams :: RawRequest -> ParamName -> [ParamValue] getParams rr name = map snd diff --git a/Web/Restful/Resource.hs b/Web/Restful/Resource.hs index d253edb3..2415f776 100644 --- a/Web/Restful/Resource.hs +++ b/Web/Restful/Resource.hs @@ -1,5 +1,8 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} --------------------------------------------------------- -- -- Module : Web.Restful.Resource @@ -17,6 +20,10 @@ module Web.Restful.Resource ( ResourceName (..) , fromString , checkPattern + , validatePatterns + , checkResourceName + -- * Testing + , testSuite ) where import Data.List.Split (splitOn) @@ -24,20 +31,33 @@ import Web.Restful.Definitions import Web.Restful.Handler import Data.List (intercalate) +import Test.Framework (testGroup, Test) +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck (testProperty) +import Test.HUnit hiding (Test) +import Test.QuickCheck + data ResourcePatternPiece = Static String | Dynamic String | Slurp String -- ^ take up the rest of the pieces. must be last - deriving Show + deriving Eq +instance Show ResourcePattern where + show = concatMap helper . unRP where + helper (Static s) = '/' : s + helper (Dynamic s) = '/' : '$' : s + helper (Slurp s) = '/' : '*' : s isSlurp :: ResourcePatternPiece -> Bool isSlurp (Slurp _) = True isSlurp _ = False -type ResourcePattern = [ResourcePatternPiece] +newtype ResourcePattern = ResourcePattern { unRP :: [ResourcePatternPiece] } + deriving (Eq, Arbitrary) fromString :: String -> ResourcePattern -fromString = map fromString' . filter (not . null) . splitOn "/" +fromString = ResourcePattern + . map fromString' . filter (not . null) . splitOn "/" fromString' :: String -> ResourcePatternPiece fromString' ('$':rest) = Dynamic rest @@ -61,18 +81,19 @@ class Show a => ResourceName a b | a -> b where -- | Find the handler for each resource name/verb pattern. getHandler :: b -> a -> Verb -> Handler --- FIXME add some overlap checking functions - type SMap = [(String, String)] data CheckPatternReturn = StaticMatch | DynamicMatch (String, String) | NoMatch checkPattern :: ResourcePattern -> Resource -> Maybe SMap -checkPattern rp r +checkPattern rp r = checkPattern'' (unRP rp) r + +checkPattern'' :: [ResourcePatternPiece] -> Resource -> Maybe SMap +checkPattern'' rp r | length rp /= 0 && isSlurp (last rp) = do let rp' = init rp (r1, r2) = splitAt (length rp') r - smap <- checkPattern rp' r1 + smap <- checkPattern'' rp' r1 let slurpValue = intercalate "/" r2 Slurp slurpKey = last rp return $ (slurpKey, slurpValue) : smap @@ -89,3 +110,79 @@ combine s [] = Just $ reverse s combine _ (NoMatch:_) = Nothing combine s (StaticMatch:rest) = combine s rest combine s (DynamicMatch x:rest) = combine (x:s) rest + +overlaps :: [ResourcePatternPiece] -> [ResourcePatternPiece] -> Bool +overlaps [] [] = True +overlaps [] _ = False +overlaps _ [] = False +overlaps (Slurp _:_) _ = True +overlaps _ (Slurp _:_) = True +overlaps (Dynamic _:x) (_:y) = overlaps x y +overlaps (_:x) (Dynamic _:y) = overlaps x y +overlaps (Static a:x) (Static b:y) = a == b && overlaps x y + +checkResourceName :: (Monad m, ResourceName rn model) => rn -> m () +checkResourceName rn = do + let avs@(y:_) = allValues + _ignore = asTypeOf rn y + let patterns = map (fromString . resourcePattern) avs + case validatePatterns patterns of + [] -> return () + x -> fail $ "Overlapping patterns:\n" ++ unlines (map show x) + +validatePatterns :: [ResourcePattern] -> [(ResourcePattern, ResourcePattern)] +validatePatterns [] = [] +validatePatterns (x:xs) = + concatMap (validatePatterns' x) xs ++ validatePatterns xs where + validatePatterns' :: ResourcePattern + -> ResourcePattern + -> [(ResourcePattern, ResourcePattern)] + validatePatterns' a b = + if overlaps (unRP a) (unRP b) + then [(a, b)] + else [] +---- Testing +testSuite :: Test +testSuite = testGroup "Web.Restful.Resource" + [ testCase "non-overlap" case_overlap1 + , testCase "overlap" case_overlap2 + , testCase "overlap-slurp" case_overlap3 + , testCase "validatePatterns" case_validatePatterns + , testProperty "show pattern" prop_showPattern + ] + +case_overlap1 :: Assertion +case_overlap1 = assert $ not $ overlaps + (unRP $ fromString "/foo/$bar/") + (unRP $ fromString "/foo/baz/$bin") +case_overlap2 :: Assertion +case_overlap2 = assert $ overlaps + (unRP $ fromString "/foo/bar") + (unRP $ fromString "/foo/$baz") +case_overlap3 :: Assertion +case_overlap3 = assert $ overlaps + (unRP $ fromString "/foo/bar/baz/$bin") + (unRP $ fromString "*slurp") + +case_validatePatterns :: Assertion +case_validatePatterns = + let p1 = fromString "/foo/bar/baz" + p2 = fromString "/foo/$bar/baz" + p3 = fromString "/bin" + p4 = fromString "/bin/boo" + p5 = fromString "/bin/*slurp" + in validatePatterns [p1, p2, p3, p4, p5] @?= + [ (p1, p2) + , (p4, p5) + ] + +prop_showPattern :: ResourcePattern -> Bool +prop_showPattern p = fromString (show p) == p + +instance Arbitrary ResourcePatternPiece where + arbitrary = do + constr <- elements [Static, Dynamic, Slurp] + size <- elements [1..10] + s <- sequence (replicate size $ elements ['a'..'z']) + return $ constr s + coarbitrary = undefined diff --git a/Web/Restful/Response.hs b/Web/Restful/Response.hs index d8f15dce..c5db6c1d 100644 --- a/Web/Restful/Response.hs +++ b/Web/Restful/Response.hs @@ -29,6 +29,8 @@ module Web.Restful.Response , genResponse , htmlResponse , objectResponse + -- * Tests + , testSuite ) where import Data.ByteString.Class @@ -39,6 +41,8 @@ import Data.Object.Instances import Web.Restful.Utils (formatW3) +import Test.Framework (testGroup, Test) + type ContentType = String type Reps = [(ContentType, B.ByteString)] @@ -120,3 +124,9 @@ instance HasReps Object where instance HasReps [(ContentType, B.ByteString)] where reps = id + +----- Testing +testSuite :: Test +testSuite = testGroup "Web.Restful.Response" + [ + ] diff --git a/Web/Restful/Utils.hs b/Web/Restful/Utils.hs index 43a62179..66e36db7 100644 --- a/Web/Restful/Utils.hs +++ b/Web/Restful/Utils.hs @@ -16,6 +16,7 @@ module Web.Restful.Utils ( parseHttpAccept , tryLookup , formatW3 + , testSuite ) where import Data.List.Split (splitOneOf) @@ -25,6 +26,10 @@ import Data.Time.Clock import System.Locale import Data.Time.Format +import Test.Framework (testGroup, Test) +import Test.Framework.Providers.HUnit +import Test.HUnit hiding (Test) + -- | Parse the HTTP accept string to determine supported content types. parseHttpAccept :: String -> [String] parseHttpAccept = filter (not . specialHttpAccept) . splitOneOf ";," @@ -41,3 +46,16 @@ tryLookup def key = fromMaybe def . lookup key -- | Format a 'UTCTime' in W3 format; useful for setting cookies. formatW3 :: UTCTime -> String formatW3 = formatTime defaultTimeLocale "%FT%X-08:00" -- FIXME time zone? + +----- Testing +testSuite :: Test +testSuite = testGroup "Web.Restful.Response" + [ testCase "tryLookup1" test_tryLookup1 + , testCase "tryLookup2" test_tryLookup2 + ] + +test_tryLookup1 :: Assertion +test_tryLookup1 = tryLookup "default" "foo" [] @?= "default" + +test_tryLookup2 :: Assertion +test_tryLookup2 = tryLookup "default" "foo" [("foo", "baz")] @?= "baz" diff --git a/restful.cabal b/restful.cabal index 73dce39d..029211bb 100644 --- a/restful.cabal +++ b/restful.cabal @@ -27,10 +27,15 @@ library predicates >= 0.1, bytestring >= 0.9.1.4, bytestring-class, - web-encodings, + web-encodings >= 0.0.1, mtl >= 1.1.0.2, data-object, - yaml >= 0.0.1 + yaml >= 0.0.1, + test-framework, + test-framework-quickcheck, + test-framework-hunit, + HUnit, + QuickCheck == 1.* exposed-modules: Web.Restful, Web.Restful.Constants, Web.Restful.Request, @@ -47,4 +52,4 @@ library Web.Restful.Response.AtomFeed, Web.Restful.Response.Sitemap, Web.Restful.Generic.ListDetail - ghc-options: -Wall + ghc-options: -Wall -Werror