Int patterns
This commit is contained in:
parent
43b0185049
commit
f232ae6fd9
1
TODO
1
TODO
@ -1,2 +1 @@
|
|||||||
Catch exceptions and return as 500 errors
|
Catch exceptions and return as 500 errors
|
||||||
int patterns (#name)
|
|
||||||
|
|||||||
@ -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
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user