diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index 2ba20f68..7b67028e 100644 --- a/Yesod/Resource.hs +++ b/Yesod/Resource.hs @@ -36,6 +36,7 @@ module Yesod.Resource , VerbMap (..) , RP (..) , RPP (..) + , UrlParam (..) #if TEST -- * Testing , testSuite @@ -44,7 +45,7 @@ module Yesod.Resource import Data.List.Split (splitOn) import Yesod.Definitions -import Data.List (intercalate, nub) +import Data.List (nub) import Data.Char (isDigit) import Control.Monad (when) @@ -58,6 +59,8 @@ import Data.Object.Text import Control.Monad ((<=<)) import Data.Object.Yaml import Yesod.Handler +import Data.Maybe (fromJust) +import Yesod.Rep #if TEST import Control.Monad (replicateM) @@ -101,11 +104,10 @@ instance ConvertSuccess RP String where type ResourcePattern = String -type SMap = [(String, String)] - data CheckPatternReturn = StaticMatch | DynamicMatch (String, String) + | DynIntMatch (String, Int) | NoMatch checkPatternBool :: RP -> Resource -> Bool @@ -113,7 +115,10 @@ checkPatternBool rp r = case checkPattern rp r of Nothing -> False _ -> True -checkPattern :: RP -> Resource -> Maybe SMap +checkPatternUP :: RP -> Resource -> [UrlParam] +checkPatternUP rp r = map snd $ fromJust (checkPattern rp r) + +checkPattern :: RP -> Resource -> Maybe [(String, UrlParam)] checkPattern = checkPatternPieces . unRP checkPatternsTH :: Bool -> [ResourcePattern] -> Q Exp @@ -121,15 +126,14 @@ checkPatternsTH toCheck patterns = do runIO $ when toCheck $ checkPatterns patterns [|return ()|] -checkPatternPieces :: [RPP] -> Resource -> Maybe SMap +checkPatternPieces :: [RPP] -> Resource -> Maybe [(String, UrlParam)] checkPatternPieces rp r | not (null rp) && isSlurp (last rp) = do let rp' = init rp (r1, r2) = splitAt (length rp') r smap <- checkPatternPieces rp' r1 - let slurpValue = intercalate "/" r2 - Slurp slurpKey = last rp - return $ (slurpKey, slurpValue) : smap + let Slurp slurpKey = last rp + return $ (slurpKey, SlurpParam r2) : smap | length rp /= length r = Nothing | otherwise = combine [] $ zipWith checkPattern' rp r @@ -138,14 +142,17 @@ 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" checkPattern' (DynInt x) y - | all isDigit y = DynamicMatch (x, y) + | all isDigit y = DynIntMatch (x, read y) | otherwise = NoMatch -combine :: SMap -> [CheckPatternReturn] -> Maybe SMap +combine :: [(String, UrlParam)] + -> [CheckPatternReturn] + -> Maybe [(String, UrlParam)] combine s [] = Just $ reverse s combine _ (NoMatch:_) = Nothing combine s (StaticMatch:rest) = combine s rest -combine s (DynamicMatch x:rest) = combine (x:s) rest +combine s (DynamicMatch (x, y):rest) = combine ((x, StringParam y):s) rest +combine s (DynIntMatch (x, y):rest) = combine ((x, IntParam y):s) rest overlaps :: [RPP] -> [RPP] -> Bool overlaps [] [] = True @@ -261,13 +268,67 @@ rpnodesTH ns = do helper2 (RPNode rp vm) = do rp' <- lift rp cpb <- [|checkPatternBool|] - let g = cpb `AppE` rp' `AppE` VarE (mkName "resource") - vm' <- lift vm - return (NormalG g, vm') + let r' = VarE $ mkName "resource" + let g = cpb `AppE` rp' `AppE` r' + vm' <- liftVerbMap vm $ countParams rp + vm'' <- applyUrlParams rp r' vm' + let vm''' = LamE [VarP $ mkName "verb"] vm'' + return (NormalG g, vm''') + +data UrlParam = SlurpParam { slurpParam :: [String] } + | StringParam { stringParam :: String } + | IntParam { intParam :: Int } + deriving Show -- FIXME remove + +getUrlParam :: RP -> Resource -> Int -> UrlParam +getUrlParam rp r i = checkPatternUP rp r !! i + +getUrlParamSlurp :: RP -> Resource -> Int -> [String] +getUrlParamSlurp rp r = slurpParam . getUrlParam rp r + +getUrlParamString :: RP -> Resource -> Int -> String +getUrlParamString rp r = stringParam . getUrlParam rp r + +getUrlParamInt :: RP -> Resource -> Int -> Int +getUrlParamInt rp r = intParam . getUrlParam rp r + +applyUrlParams :: RP -> Exp -> Exp -> Q Exp +applyUrlParams rp@(RP rpps) r f = do + getFs <- helper 0 rpps + return $ foldl AppE f getFs + where + helper :: Int -> [RPP] -> Q [Exp] + helper _ [] = return [] + helper i (Static _:rest) = helper i rest + helper i (Dynamic _:rest) = do + rp' <- lift rp + str <- [|getUrlParamString|] + i' <- lift i + rest' <- helper (i + 1) rest + return $ str `AppE` rp' `AppE` r `AppE` i' : rest' + helper i (DynInt _:rest) = do + rp' <- lift rp + int <- [|getUrlParamInt|] + i' <- lift i + rest' <- helper (i + 1) rest + return $ int `AppE` rp' `AppE` r `AppE` i' : rest' + helper i (Slurp _:rest) = do + rp' <- lift rp + slurp <- [|getUrlParamSlurp|] + i' <- lift i + rest' <- helper (i + 1) rest + return $ slurp `AppE` rp' `AppE` r `AppE` i' : rest' + +countParams :: RP -> Int +countParams (RP rpps) = helper 0 rpps where + helper i [] = i + helper i (Static _:rest) = helper i rest + helper i (_:rest) = helper (i + 1) rest + instance Lift RPNode where lift (RPNode rp vm) = do rp' <- lift rp - vm' <- lift vm + vm' <- liftVerbMap vm $ countParams rp return $ TupE [rp', vm'] instance Lift RP where lift (RP rpps) = do @@ -282,13 +343,12 @@ instance Lift RPP where return $ ConE (mkName "DynInt") `AppE` (LitE $ StringL s) lift (Slurp s) = return $ ConE (mkName "Slurp") `AppE` (LitE $ StringL s) -instance Lift VerbMap where - lift (AllVerbs s) = - return $ LamE [VarP $ mkName "verb"] - $ (VarE $ mkName s) `AppE` (VarE $ mkName "verb") - lift (Verbs vs) = - return $ LamE [VarP $ mkName "verb"] - $ CaseE (VarE $ mkName "verb") +liftVerbMap :: VerbMap -> Int -> Q Exp +liftVerbMap (AllVerbs s) _ = do + cr <- [|(.) (fmap chooseRep)|] + return $ cr `AppE` ((VarE $ mkName s) `AppE` (VarE $ mkName "verb")) +liftVerbMap (Verbs vs) params = + return $ CaseE (VarE $ mkName "verb") $ map helper vs ++ [whenNotFound] where helper :: (Verb, String) -> Match @@ -297,7 +357,10 @@ instance Lift VerbMap where (NormalB $ VarE $ mkName f) [] whenNotFound :: Match - whenNotFound = Match WildP (NormalB $ VarE $ mkName "notFound") [] + whenNotFound = + Match WildP + (NormalB $ LamE (replicate params WildP) $ VarE $ mkName "notFound") + [] strToExp :: String -> Q Exp strToExp s = do diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs index b794b74f..1afe1ff6 100644 --- a/Yesod/Yesod.hs +++ b/Yesod/Yesod.hs @@ -17,7 +17,7 @@ import Yesod.Utils import Data.Maybe (fromMaybe) import Data.Convertible.Text import Web.Encodings -import Control.Arrow ((***)) +import Control.Arrow ((***), second) import Control.Monad (when) import qualified Hack @@ -118,7 +118,7 @@ lookupHandlers r = helper handlers where helper [] = Nothing helper ((rps, v):rest) = case checkPattern (cs rps) r of - Just up -> Just (v, up) + Just up -> Just (v, map (second show) up) Nothing -> helper rest envToRawRequest :: [(ParamName, ParamValue)] -> Hack.Env -> RawRequest diff --git a/test/quasi-resource.hs b/test/quasi-resource.hs index d30f97f7..3e8ace12 100644 --- a/test/quasi-resource.hs +++ b/test/quasi-resource.hs @@ -10,20 +10,20 @@ data MyYesod = MyYesod instance Show (Handler MyYesod RepChooser) where show _ = "Another handler" -getStatic :: Verb -> Handler MyYesod RepChooser -getStatic v = return $ chooseRep $ toHtmlObject ["getStatic", show v] +getStatic :: Verb -> [String] -> Handler MyYesod HtmlObject +getStatic v p = return $ toHtmlObject ["getStatic", show v, show p] pageIndex :: Handler MyYesod RepChooser pageIndex = return $ chooseRep $ toHtmlObject ["pageIndex"] pageAdd :: Handler MyYesod RepChooser pageAdd = return $ chooseRep $ toHtmlObject ["pageAdd"] -pageDetail :: Handler MyYesod RepChooser -pageDetail = return $ chooseRep $ toHtmlObject ["pageDetail"] -pageDelete :: Handler MyYesod RepChooser -pageDelete = return $ chooseRep $ toHtmlObject ["pageDelete"] -pageUpdate :: Handler MyYesod RepChooser -pageUpdate = return $ chooseRep $ toHtmlObject ["pageUpdate"] -userInfo :: Handler MyYesod RepChooser -userInfo = return $ chooseRep $ toHtmlObject ["userInfo"] +pageDetail :: String -> Handler MyYesod RepChooser +pageDetail s = return $ chooseRep $ toHtmlObject ["pageDetail", s] +pageDelete :: String -> Handler MyYesod RepChooser +pageDelete s = return $ chooseRep $ toHtmlObject ["pageDelete", s] +pageUpdate :: String -> Handler MyYesod RepChooser +pageUpdate s = return $ chooseRep $ toHtmlObject ["pageUpdate", s] +userInfo :: Int -> Handler MyYesod RepChooser +userInfo i = return $ chooseRep $ toHtmlObject ["userInfo", show i] instance Show (Verb -> Handler MyYesod RepChooser) where show _ = "verb -> handler"