Route parsing

yesod-core/Yesod/Core.hs

@@ -10,6 +10,7 @@ module Yesod.Core
     , YesodDispatch (..)
     , YesodSubDispatch (..)
     , RenderRoute (..)
+    , ParseRoute (..)
       -- ** Breadcrumbs
     , YesodBreadcrumbs (..)
     , breadcrumbs
@@ -85,6 +86,7 @@ import Text.Blaze.Html (Html)
 import Control.Monad.Logger
 import Control.Monad.Trans.Class (MonadTrans (..))
 import Yesod.Core.Internal.Session
+import Yesod.Core.Internal.TH (ParseRoute (..))
 import Yesod.Core.Class.Yesod
 import Yesod.Core.Class.Dispatch
 import Yesod.Core.Class.Breadcrumbs

yesod-core/Yesod/Core/Internal/TH.hs

@@ -22,6 +22,12 @@ import Yesod.Core.Types
 import Yesod.Core.Content
 import Yesod.Core.Class.Dispatch
 import Yesod.Core.Internal.Run
+import Yesod.Routes.Class
+import Data.Text (Text)
+import qualified Data.ByteString.Char8 as S8
+
+class RenderRoute a => ParseRoute a where
+    parseRoute :: ([Text], [(Text, Text)]) -> Maybe (Route a)
 
 -- | Generates URL datatype and site function for the given 'Resource's. This
 -- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter.
@@ -73,7 +79,8 @@ mkYesodGeneral :: String                   -- ^ foundation type
 mkYesodGeneral name args isSub resS = do
      renderRouteDec <- mkRenderRouteInstance site res
      dispatchDec    <- mkDispatchInstance site res
-     return (renderRouteDec ++ if isSub then [] else masterTypeSyns site, dispatchDec)
+     parse <- mkParseRoute site res
+     return (parse : renderRouteDec ++ if isSub then [] else masterTypeSyns site, dispatchDec)
   where site    = foldl' AppT (ConT $ mkName name) (map (VarT . mkName) args)
         res     = map (fmap parseType) resS
 
@@ -94,6 +101,7 @@ mkMDS rh = MkDispatchSettings
     , mdsMethod = [|W.requestMethod|]
     , mds404 = [|notFound >> return ()|]
     , mds405 = [|badMethod >> return ()|]
+    , mdsGetHandler = defaultGetHandler
     }
 
 -- | If the generation of @'YesodDispatch'@ instance require finer
@@ -111,8 +119,24 @@ mkDispatchInstance master res = do
   where
     yDispatch = ConT ''YesodDispatch `AppT` master
 
+mkParseRoute :: Type -> [ResourceTree a] -> Q Dec
+mkParseRoute typ res = do
+    Clause [VarP getEnv, req] body decs <- mkDispatchClause mds res
+    let clause = Clause [req] body $ FunD getEnv [Clause [] (NormalB $ ConE '()) []] : decs
+    return $ InstanceD [] (ConT ''ParseRoute `AppT` typ) [FunD 'parseRoute [clause]]
+  where
+    mds = MkDispatchSettings
+        { mdsRunHandler = [|\_ _ route _ -> route |]
+        , mdsSubDispatcher = [|\_ _ toParent _ req -> fmap toParent $ parseRoute req|]
+        , mdsGetPathInfo = [|fst|]
+        , mdsSetPathInfo = [|\p (_, q) -> (p, q)|]
+        , mdsMethod = [|const $ S8.pack "GET"|]
+        , mds404 = [|const ()|]
+        , mds405 = [|const ()|]
+        , mdsGetHandler = \_ _ -> [|const ()|]
+        }
 
-mkYesodSubDispatch :: [ResourceTree String] -> Q Exp
+mkYesodSubDispatch :: [ResourceTree a] -> Q Exp
 mkYesodSubDispatch res = do
     clause' <- mkDispatchClause (mkMDS [|subHelper . fmap toTypedContent|]) res
     inner <- newName "inner"

yesod-core/test/YesodCoreTest/CleanPath.hs

@@ -28,6 +28,8 @@ instance RenderRoute Subsite where
     data Route Subsite = SubsiteRoute [TS.Text]
         deriving (Eq, Show, Read)
     renderRoute (SubsiteRoute x) = (x, [])
+instance ParseRoute Subsite where
+    parseRoute (x, _) = Just $ SubsiteRoute x
 
 instance YesodSubDispatch Subsite master where
     yesodSubDispatch _ req = return $ responseLBS
@@ -84,6 +86,11 @@ cleanPathTest =
       it "/foo/something" fooSomething
       it "subsite dispatch" subsiteDispatch
       it "redirect with query string" redQueryString
+      it "parsing" $ do
+        parseRoute (["foo"], []) `shouldBe` Just FooR
+        parseRoute (["foo", "bar"], []) `shouldBe` Just (FooStringR "bar")
+        parseRoute (["subsite", "some", "path"], []) `shouldBe` Just (SubsiteR $ SubsiteRoute ["some", "path"])
+        parseRoute (["ignore", "me"], []) `shouldBe` (Nothing :: Maybe (Route Y))
 
 runner :: Session () -> IO ()
 runner f = toWaiApp Y >>= runSession f

yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs

@@ -23,7 +23,7 @@ getBazR = lift $ defaultLayout [whamlet|Used Default Layout|]
 
 getBinR :: Yesod master => HandlerT Subsite (HandlerT master IO) RepHtml
 getBinR = do
-    widget <- liftWidget [whamlet|
+    widget <- widgetToParentWidget [whamlet|
         <p>Used defaultLayoutT
         <a href=@{BazR}>Baz
     |]

yesod-core/yesod-core.cabal

@@ -120,7 +120,7 @@ test-suite tests
     cpp-options:   -DTEST
     build-depends: base
                   ,hspec >= 1.3
-                  ,wai-test
+                  ,wai-test >= 1.3.0.5
                   ,wai
                   ,yesod-core
                   ,bytestring

yesod-routes/Yesod/Routes/TH/Dispatch.hs

@@ -3,6 +3,7 @@ module Yesod.Routes.TH.Dispatch
     ( -- ** Dispatch
       mkDispatchClause
     , MkDispatchSettings (..)
+    , defaultGetHandler
     ) where
 
 import Prelude hiding (exp)
@@ -37,8 +38,12 @@ data MkDispatchSettings = MkDispatchSettings
     , mdsMethod :: Q Exp
     , mds404 :: Q Exp
     , mds405 :: Q Exp
+    , mdsGetHandler :: Maybe String -> String -> Q Exp
     }
 
+defaultGetHandler Nothing s = return $ VarE $ mkName $ "handle" ++ s
+defaultGetHandler (Just method) s = return $ VarE $ mkName $ map toLower method ++ s
+
 -- |
 --
 -- This function will generate a single clause that will address all
@@ -171,7 +176,7 @@ buildMethodMap mds (FlatResource parents name pieces' (Methods mmulti methods))
   where
     pieces = concat $ map snd parents ++ [pieces']
     go method = do
-        let func = VarE $ mkName $ map toLower method ++ name
+        func <- mdsGetHandler mds (Just method) name
         pack' <- [|encodeUtf8 . pack|]
         let isDynamic Dynamic{} = True
             isDynamic _ = False
@@ -317,7 +322,8 @@ buildCaller mds xrest parents name resDisp ys = do
                 if null ms
                     then do
                         -- Just a single handler
-                        let he = foldl' (\a b -> a `AppE` VarE b) (VarE $ mkName $ "handle" ++ name) ys
+                        base <- mdsGetHandler mds Nothing name
+                        let he = foldl' (\a b -> a `AppE` VarE b) base ys
                         runHandler <- mdsRunHandler mds
                         return $ myLet $ runHandler `AppE` he
                     else do