diff --git a/Yesod/Rep.hs b/Yesod/Rep.hs index 796fd783..0b505e50 100644 --- a/Yesod/Rep.hs +++ b/Yesod/Rep.hs @@ -29,8 +29,8 @@ module Yesod.Rep ( ContentType (..) , Content (..) - , Rep - , Reps + , RepChooser + , ContentPair , HasReps (..) -- FIXME TemplateFile or some such... -- * Specific types of representations @@ -103,16 +103,20 @@ instance ConvertSuccess ByteString Content where instance ConvertSuccess String Content where convertSuccess = Content . cs -type Rep a = (ContentType, a -> Content) -type Reps a = [Rep a] +type ContentPair = (ContentType, Content) +type RepChooser = [ContentType] -> ContentPair -- | Any type which can be converted to representations. There must be at least -- one representation for each type. class HasReps a where - reps :: Reps a - chooseRep :: a -> [ContentType] -> (ContentType, Content) + reps :: [(ContentType, a -> Content)] + chooseRep :: a -> RepChooser chooseRep = chooseRep' +instance HasReps RepChooser where + reps = error "reps of RepChooser" + chooseRep = id + instance HasReps [(ContentType, Content)] where reps = error "reps of [(ContentType, Content)]" chooseRep a cts = diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index 03a89f9a..455c6c09 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -20,8 +20,7 @@ -- --------------------------------------------------------- module Yesod.Resource - ( ResourcePatternString -- FIXME rename - , fromString -- FIXME rename + ( ResourcePattern , checkPattern , validatePatterns , checkResourceName @@ -39,6 +38,7 @@ import Data.Char (isDigit) import Data.Typeable (Typeable) import Control.Exception (Exception) import Data.Attempt -- for failure stuff +import Data.Convertible.Text #if TEST import Control.Monad (replicateM, when) @@ -49,38 +49,39 @@ import Test.HUnit hiding (Test) import Test.QuickCheck #endif -data ResourcePatternPiece = +-- | Resource Pattern Piece +data RPP = Static String | Dynamic String | DynInt String | Slurp String -- ^ take up the rest of the pieces. must be last deriving Eq -instance Show ResourcePattern where + +-- | Resource Pattern +newtype RP = RP { unRP :: [RPP] } + deriving Eq + +instance Show RP where show = concatMap helper . unRP where helper (Static s) = '/' : s helper (Dynamic s) = '/' : '$' : s helper (Slurp s) = '/' : '*' : s helper (DynInt s) = '/' : '#' : s -isSlurp :: ResourcePatternPiece -> Bool +isSlurp :: RPP -> Bool isSlurp (Slurp _) = True isSlurp _ = False -newtype ResourcePattern = ResourcePattern { unRP :: [ResourcePatternPiece] } - deriving Eq +instance ConvertSuccess String RP where + convertSuccess = RP . map helper . filter (not . null) .splitOn "/" + where + helper :: String -> RPP + helper ('$':rest) = Dynamic rest + helper ('*':rest) = Slurp rest + helper ('#':rest) = DynInt rest + helper x = Static x --- | FIXME not a good name for the function. Use convertible -fromString :: String -> ResourcePattern -fromString = ResourcePattern - . map fromString' . filter (not . null) . splitOn "/" - -fromString' :: String -> ResourcePatternPiece -fromString' ('$':rest) = Dynamic rest -fromString' ('*':rest) = Slurp rest -fromString' ('#':rest) = DynInt rest -fromString' x = Static x - -type ResourcePatternString = String +type ResourcePattern = String type SMap = [(String, String)] @@ -89,10 +90,10 @@ data CheckPatternReturn = | DynamicMatch (String, String) | NoMatch -checkPattern :: ResourcePattern -> Resource -> Maybe SMap +checkPattern :: RP -> Resource -> Maybe SMap checkPattern = checkPatternPieces . unRP -checkPatternPieces :: [ResourcePatternPiece] -> Resource -> Maybe SMap +checkPatternPieces :: [RPP] -> Resource -> Maybe SMap checkPatternPieces rp r | not (null rp) && isSlurp (last rp) = do let rp' = init rp @@ -104,7 +105,7 @@ checkPatternPieces rp r | length rp /= length r = Nothing | otherwise = combine [] $ zipWith checkPattern' rp r -checkPattern' :: ResourcePatternPiece -> String -> CheckPatternReturn +checkPattern' :: RPP -> String -> CheckPatternReturn checkPattern' (Static x) y = if x == y then StaticMatch else NoMatch checkPattern' (Dynamic x) y = DynamicMatch (x, y) checkPattern' (Slurp x) _ = error $ "Slurp pattern " ++ x ++ " must be last" @@ -118,7 +119,7 @@ combine _ (NoMatch:_) = Nothing combine s (StaticMatch:rest) = combine s rest combine s (DynamicMatch x:rest) = combine (x:s) rest -overlaps :: [ResourcePatternPiece] -> [ResourcePatternPiece] -> Bool +overlaps :: [RPP] -> [RPP] -> Bool overlaps [] [] = True overlaps [] _ = False overlaps _ [] = False @@ -141,22 +142,25 @@ data OverlappingPatterns = instance Exception OverlappingPatterns checkResourceName :: MonadFailure OverlappingPatterns f - => [ResourcePatternString] + => [ResourcePattern] -> f () -checkResourceName patterns' = - let patterns = map fromString patterns' - in case validatePatterns patterns of +checkResourceName patterns = + case validatePatterns patterns of [] -> return () x -> failure $ OverlappingPatterns x -validatePatterns :: [ResourcePattern] -> [(ResourcePattern, ResourcePattern)] +validatePatterns :: [ResourcePattern] + -> [(ResourcePattern, ResourcePattern)] validatePatterns [] = [] validatePatterns (x:xs) = concatMap (validatePatterns' x) xs ++ validatePatterns xs where validatePatterns' :: ResourcePattern - -> ResourcePattern - -> [(ResourcePattern, ResourcePattern)] - validatePatterns' a b = [(a, b) | overlaps (unRP a) (unRP b)] + -> ResourcePattern + -> [(ResourcePattern, ResourcePattern)] + validatePatterns' a b = + let a' = unRP $ cs a + b' = unRP $ cs b + in [(a, b) | overlaps a' b'] #if TEST ---- Testing @@ -170,35 +174,35 @@ testSuite = testGroup "Yesod.Resource" , testCase "integers" caseIntegers ] -deriving instance Arbitrary ResourcePattern +deriving instance Arbitrary RP caseOverlap1 :: Assertion caseOverlap1 = assert $ not $ overlaps - (unRP $ fromString "/foo/$bar/") - (unRP $ fromString "/foo/baz/$bin") + (unRP $ cs "/foo/$bar/") + (unRP $ cs "/foo/baz/$bin") caseOverlap2 :: Assertion caseOverlap2 = assert $ overlaps - (unRP $ fromString "/foo/bar") - (unRP $ fromString "/foo/$baz") + (unRP $ cs "/foo/bar") + (unRP $ cs "/foo/$baz") caseOverlap3 :: Assertion caseOverlap3 = assert $ overlaps - (unRP $ fromString "/foo/bar/baz/$bin") - (unRP $ fromString "*slurp") + (unRP $ cs "/foo/bar/baz/$bin") + (unRP $ cs "*slurp") caseValidatePatterns :: Assertion caseValidatePatterns = - let p1 = fromString "/foo/bar/baz" - p2 = fromString "/foo/$bar/baz" - p3 = fromString "/bin" - p4 = fromString "/bin/boo" - p5 = fromString "/bin/*slurp" + let p1 = cs "/foo/bar/baz" + p2 = cs "/foo/$bar/baz" + p3 = cs "/bin" + p4 = cs "/bin/boo" + p5 = cs "/bin/*slurp" in validatePatterns [p1, p2, p3, p4, p5] @?= [ (p1, p2) , (p4, p5) ] -prop_showPattern :: ResourcePattern -> Bool -prop_showPattern p = fromString (show p) == p +prop_showPattern :: RP -> Bool +prop_showPattern p = cs (show p) == p caseIntegers :: Assertion caseIntegers = do @@ -210,8 +214,8 @@ caseIntegers = do 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) + let res1 = overlaps (unRP $ cs a) (unRP $ cs b) + let res2 = overlaps (unRP $ cs b) (unRP $ cs a) when (res1 /= c || res2 /= c) $ assertString $ a ++ (if c then " does not overlap with " else " overlaps with ") ++ b @@ -221,7 +225,7 @@ caseIntegers = do checkOverlap p1 p5 False checkOverlap p1 p6 True -instance Arbitrary ResourcePatternPiece where +instance Arbitrary RPP where arbitrary = do constr <- elements [Static, Dynamic, Slurp, DynInt] size <- elements [1..10] diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index a8e5af05..7321fcae 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -26,12 +26,8 @@ import Hack.Middleware.Gzip import Hack.Middleware.Jsonp import Hack.Middleware.MethodOverride -type ContentPair = (ContentType, Content) - class Yesod a where - handlers :: - [(ResourcePatternString, - [(Verb, [ContentType] -> Handler a ContentPair)])] + handlers :: [(ResourcePattern, [(Verb, Handler a RepChooser)])] -- | The encryption key to be used for encrypting client sessions. encryptKey :: a -> IO Word256 @@ -71,8 +67,7 @@ defaultErrorHandler (InternalError e) cts = -- | For type signature reasons. handlers' :: Yesod y => y -> - [(ResourcePatternString, - [(Verb, [ContentType] -> Handler y ContentPair)])] + [(ResourcePattern, [(Verb, Handler y RepChooser)])] handlers' _ = handlers toHackApp :: Yesod y => y -> Hack.Application