Test framework; overlap checking

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 ()

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
+    ]

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)

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

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

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

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"
+    [
+    ]

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"

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