From bca0d24533a48089f2e085b15a7cebef61244eaa Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 17 Mar 2013 13:28:17 +0200 Subject: [PATCH] Route parsing --- yesod-core/Yesod/Core.hs | 2 ++ yesod-core/Yesod/Core/Internal/TH.hs | 28 +++++++++++++++++-- yesod-core/test/YesodCoreTest/CleanPath.hs | 7 +++++ .../test/YesodCoreTest/NoOverloadedStrings.hs | 2 +- yesod-core/yesod-core.cabal | 2 +- yesod-routes/Yesod/Routes/TH/Dispatch.hs | 10 +++++-- 6 files changed, 45 insertions(+), 6 deletions(-) diff --git a/yesod-core/Yesod/Core.hs b/yesod-core/Yesod/Core.hs index e660814d..1c1b4247 100644 --- a/yesod-core/Yesod/Core.hs +++ b/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 diff --git a/yesod-core/Yesod/Core/Internal/TH.hs b/yesod-core/Yesod/Core/Internal/TH.hs index 628eb7d3..e0ac60f2 100644 --- a/yesod-core/Yesod/Core/Internal/TH.hs +++ b/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" diff --git a/yesod-core/test/YesodCoreTest/CleanPath.hs b/yesod-core/test/YesodCoreTest/CleanPath.hs index f4eae3e4..451c26d2 100644 --- a/yesod-core/test/YesodCoreTest/CleanPath.hs +++ b/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 diff --git a/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs b/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs index 746c91b5..cd8b80ed 100644 --- a/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs +++ b/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|

Used defaultLayoutT Baz |] diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index c23bf1e3..53464884 100644 --- a/yesod-core/yesod-core.cabal +++ b/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 diff --git a/yesod-routes/Yesod/Routes/TH/Dispatch.hs b/yesod-routes/Yesod/Routes/TH/Dispatch.hs index d62affaa..281842fe 100644 --- a/yesod-routes/Yesod/Routes/TH/Dispatch.hs +++ b/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