URL params passed as args, chooseRep called

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
+        let Slurp slurpKey = last rp
-            Slurp slurpKey = last rp
+        return $ (slurpKey, SlurpParam r2) : smap
-        return $ (slurpKey, slurpValue) : 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")
+            let r' = VarE $ mkName "resource"
-            vm' <- lift vm
+            let g = cpb `AppE` rp' `AppE` r'
-            return (NormalG g, vm')
+            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
+liftVerbMap :: VerbMap -> Int -> Q Exp
-    lift (AllVerbs s) =
+liftVerbMap (AllVerbs s) _ = do
-      return $ LamE [VarP $ mkName "verb"]
+    cr <- [|(.) (fmap chooseRep)|]
-             $ (VarE $ mkName s) `AppE` (VarE $ mkName "verb")
+    return $ cr `AppE` ((VarE $ mkName s) `AppE` (VarE $ mkName "verb"))
-    lift (Verbs vs) =
+liftVerbMap (Verbs vs) params =
-      return $ LamE [VarP $ mkName "verb"]
+      return $ CaseE (VarE $ mkName "verb")
-             $ 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

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

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 :: Verb -> [String] -> Handler MyYesod HtmlObject
-getStatic v = return $ chooseRep $ toHtmlObject ["getStatic", show v]
+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 :: String -> Handler MyYesod RepChooser
-pageDetail = return $ chooseRep $ toHtmlObject ["pageDetail"]
+pageDetail s = return $ chooseRep $ toHtmlObject ["pageDetail", s]
-pageDelete :: Handler MyYesod RepChooser
+pageDelete :: String -> Handler MyYesod RepChooser
-pageDelete = return $ chooseRep $ toHtmlObject ["pageDelete"]
+pageDelete s = return $ chooseRep $ toHtmlObject ["pageDelete", s]
-pageUpdate :: Handler MyYesod RepChooser
+pageUpdate :: String -> Handler MyYesod RepChooser
-pageUpdate = return $ chooseRep $ toHtmlObject ["pageUpdate"]
+pageUpdate s = return $ chooseRep $ toHtmlObject ["pageUpdate", s]
-userInfo :: Handler MyYesod RepChooser
+userInfo :: Int -> Handler MyYesod RepChooser
-userInfo = return $ chooseRep $ toHtmlObject ["userInfo"]
+userInfo i = return $ chooseRep $ toHtmlObject ["userInfo", show i]
 
 instance Show (Verb -> Handler MyYesod RepChooser) where
     show _ = "verb -> handler"