Int patterns

This commit is contained in:
Michael Snoyman 2009-10-08 21:09:53 +02:00
parent 43b0185049
commit f232ae6fd9
2 changed files with 39 additions and 4 deletions

1
TODO
View File

@ -1,2 +1 @@
Catch exceptions and return as 500 errors Catch exceptions and return as 500 errors
int patterns (#name)

View File

@ -31,7 +31,8 @@ import Web.Restful.Definitions
import Web.Restful.Handler import Web.Restful.Handler
import Data.List (intercalate) import Data.List (intercalate)
import Data.Enumerable import Data.Enumerable
import Control.Monad (replicateM) import Control.Monad (replicateM, when)
import Data.Char (isDigit)
import Test.Framework (testGroup, Test) import Test.Framework (testGroup, Test)
import Test.Framework.Providers.HUnit import Test.Framework.Providers.HUnit
@ -42,6 +43,7 @@ import Test.QuickCheck
data ResourcePatternPiece = data ResourcePatternPiece =
Static String Static String
| Dynamic String | Dynamic String
| DynInt String
| Slurp String -- ^ take up the rest of the pieces. must be last | Slurp String -- ^ take up the rest of the pieces. must be last
deriving Eq deriving Eq
instance Show ResourcePattern where instance Show ResourcePattern where
@ -49,6 +51,7 @@ instance Show ResourcePattern where
helper (Static s) = '/' : s helper (Static s) = '/' : s
helper (Dynamic s) = '/' : '$' : s helper (Dynamic s) = '/' : '$' : s
helper (Slurp s) = '/' : '*' : s helper (Slurp s) = '/' : '*' : s
helper (DynInt s) = '/' : '#' : s
isSlurp :: ResourcePatternPiece -> Bool isSlurp :: ResourcePatternPiece -> Bool
isSlurp (Slurp _) = True isSlurp (Slurp _) = True
@ -64,6 +67,7 @@ fromString = ResourcePattern
fromString' :: String -> ResourcePatternPiece fromString' :: String -> ResourcePatternPiece
fromString' ('$':rest) = Dynamic rest fromString' ('$':rest) = Dynamic rest
fromString' ('*':rest) = Slurp rest fromString' ('*':rest) = Slurp rest
fromString' ('#':rest) = DynInt rest
fromString' x = Static x fromString' x = Static x
class (Show a, Enumerable a) => ResourceName a b | a -> b where class (Show a, Enumerable a) => ResourceName a b | a -> b where
@ -80,7 +84,10 @@ class (Show a, Enumerable a) => ResourceName a b | a -> b where
type SMap = [(String, String)] type SMap = [(String, String)]
data CheckPatternReturn = StaticMatch | DynamicMatch (String, String) | NoMatch data CheckPatternReturn =
StaticMatch
| DynamicMatch (String, String)
| NoMatch
checkPattern :: ResourcePattern -> Resource -> Maybe SMap checkPattern :: ResourcePattern -> Resource -> Maybe SMap
checkPattern = checkPatternPieces . unRP checkPattern = checkPatternPieces . unRP
@ -116,6 +123,13 @@ overlaps (Slurp _:_) _ = True
overlaps _ (Slurp _:_) = True overlaps _ (Slurp _:_) = True
overlaps (Dynamic _:x) (_:y) = overlaps x y overlaps (Dynamic _:x) (_:y) = overlaps x y
overlaps (_:x) (Dynamic _:y) = overlaps x y overlaps (_:x) (Dynamic _:y) = overlaps x y
overlaps (DynInt _:x) (DynInt _:y) = overlaps x y
overlaps (DynInt _:x) (Static s:y)
| all isDigit s = overlaps x y
| otherwise = False
overlaps (Static s:x) (DynInt _:y)
| all isDigit s = overlaps x y
| otherwise = False
overlaps (Static a:x) (Static b:y) = a == b && overlaps x y overlaps (Static a:x) (Static b:y) = a == b && overlaps x y
checkResourceName :: (Monad m, ResourceName rn model) => rn -> m () checkResourceName :: (Monad m, ResourceName rn model) => rn -> m ()
@ -144,6 +158,7 @@ testSuite = testGroup "Web.Restful.Resource"
, testCase "overlap-slurp" caseOverlap3 , testCase "overlap-slurp" caseOverlap3
, testCase "validatePatterns" caseValidatePatterns , testCase "validatePatterns" caseValidatePatterns
, testProperty "show pattern" prop_showPattern , testProperty "show pattern" prop_showPattern
, testCase "integers" caseIntegers
] ]
caseOverlap1 :: Assertion caseOverlap1 :: Assertion
@ -174,9 +189,30 @@ caseValidatePatterns =
prop_showPattern :: ResourcePattern -> Bool prop_showPattern :: ResourcePattern -> Bool
prop_showPattern p = fromString (show p) == p prop_showPattern p = fromString (show p) == p
caseIntegers :: Assertion
caseIntegers = do
let p1 = "/foo/#bar/"
p2 = "/foo/#baz/"
p3 = "/foo/$bin/"
p4 = "/foo/4/"
p5 = "/foo/bar/"
p6 = "/foo/*slurp/"
checkOverlap :: String -> String -> Bool -> IO ()
checkOverlap a b c = do
let res1 = overlaps (unRP $ fromString a) (unRP $ fromString b)
let res2 = overlaps (unRP $ fromString b) (unRP $ fromString a)
when (res1 /= c || res2 /= c) $ assertString $ a
++ (if c then " does not overlap with " else " overlaps with ")
++ b
checkOverlap p1 p2 True
checkOverlap p1 p3 True
checkOverlap p1 p4 True
checkOverlap p1 p5 False
checkOverlap p1 p6 True
instance Arbitrary ResourcePatternPiece where instance Arbitrary ResourcePatternPiece where
arbitrary = do arbitrary = do
constr <- elements [Static, Dynamic, Slurp] constr <- elements [Static, Dynamic, Slurp, DynInt]
size <- elements [1..10] size <- elements [1..10]
s <- replicateM size $ elements ['a'..'z'] s <- replicateM size $ elements ['a'..'z']
return $ constr s return $ constr s