From 56c19a2cd3bb41df2ee781ec4296a0f184cf0500 Mon Sep 17 00:00:00 2001 From: Eric Easley Date: Wed, 9 Dec 2015 11:29:13 -0800 Subject: [PATCH] Add hook to apply arbitrary function to all handlers --- yesod-core/Yesod/Core/Internal.hs | 1 + yesod-core/Yesod/Core/Internal/TH.hs | 37 +++++++++++++----------- yesod-core/Yesod/Routes/TH/Dispatch.hs | 8 +++-- yesod-core/Yesod/Routes/TH/ParseRoute.hs | 1 + 4 files changed, 27 insertions(+), 20 deletions(-) diff --git a/yesod-core/Yesod/Core/Internal.hs b/yesod-core/Yesod/Core/Internal.hs index e60e4d6e..28c16930 100644 --- a/yesod-core/Yesod/Core/Internal.hs +++ b/yesod-core/Yesod/Core/Internal.hs @@ -5,3 +5,4 @@ module Yesod.Core.Internal ) where import Yesod.Core.Internal.Request as X (randomString, parseWaiRequest) +import Yesod.Core.Internal.TH as X (mkYesodGeneral) diff --git a/yesod-core/Yesod/Core/Internal/TH.hs b/yesod-core/Yesod/Core/Internal/TH.hs index 370c691a..7fb4a28d 100644 --- a/yesod-core/Yesod/Core/Internal/TH.hs +++ b/yesod-core/Yesod/Core/Internal/TH.hs @@ -32,13 +32,13 @@ import Yesod.Core.Internal.Run mkYesod :: String -- ^ name of the argument datatype -> [ResourceTree String] -> Q [Dec] -mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] False +mkYesod name = fmap (uncurry (++)) . mkYesodGeneral name [] False return mkYesodWith :: String -> [Either String [String]] -> [ResourceTree String] -> Q [Dec] -mkYesodWith name args = fmap (uncurry (++)) . mkYesodGeneral name args False +mkYesodWith name args = fmap (uncurry (++)) . mkYesodGeneral name args False return -- | Sometimes, you will want to declare your routes in one file and define -- your handlers elsewhere. For example, this is the only way to break up a @@ -53,11 +53,11 @@ mkYesodSubData name res = mkYesodDataGeneral name True res mkYesodDataGeneral :: String -> Bool -> [ResourceTree String] -> Q [Dec] mkYesodDataGeneral name isSub res = do let (name':rest) = words name - fmap fst $ mkYesodGeneral name' (fmap Left rest) isSub res + fmap fst $ mkYesodGeneral name' (fmap Left rest) isSub return res -- | See 'mkYesodData'. mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec] -mkYesodDispatch name = fmap snd . mkYesodGeneral name [] False +mkYesodDispatch name = fmap snd . mkYesodGeneral name [] False return -- | Get the Handler and Widget type synonyms for the given site. masterTypeSyns :: [Name] -> Type -> [Dec] @@ -71,12 +71,13 @@ masterTypeSyns vs site = -- | 'Left' arguments indicate a monomorphic type, a 'Right' argument -- indicates a polymorphic type, and provides the list of classes -- the type must be instance of. -mkYesodGeneral :: String -- ^ foundation type - -> [Either String [String]] -- ^ arguments for the type - -> Bool -- ^ is this a subsite +mkYesodGeneral :: String -- ^ foundation type + -> [Either String [String]] -- ^ arguments for the type + -> Bool -- ^ is this a subsite + -> (Exp -> Q Exp) -- ^ unwrap handler -> [ResourceTree String] -> Q([Dec],[Dec]) -mkYesodGeneral namestr args isSub resS = do +mkYesodGeneral namestr args isSub f resS = do mname <- lookupTypeName namestr arity <- case mname of Just name -> do @@ -112,7 +113,7 @@ mkYesodGeneral namestr args isSub resS = do res = map (fmap parseType) resS renderRouteDec <- mkRenderRouteInstance site res routeAttrsDec <- mkRouteAttrsInstance site res - dispatchDec <- mkDispatchInstance site cxt res + dispatchDec <- mkDispatchInstance site cxt f res parse <- mkParseRouteInstance site res let rname = mkName $ "resources" ++ namestr eres <- lift resS @@ -129,8 +130,8 @@ mkYesodGeneral namestr args isSub resS = do ] return (dataDec, dispatchDec) -mkMDS :: Q Exp -> MkDispatchSettings -mkMDS rh = MkDispatchSettings +mkMDS :: (Exp -> Q Exp) -> Q Exp -> MkDispatchSettings a site b +mkMDS f rh = MkDispatchSettings { mdsRunHandler = rh , mdsSubDispatcher = [|\parentRunner getSub toParent env -> yesodSubDispatch @@ -147,6 +148,7 @@ mkMDS rh = MkDispatchSettings , mds404 = [|notFound >> return ()|] , mds405 = [|badMethod >> return ()|] , mdsGetHandler = defaultGetHandler + , mdsUnwrapper = f } -- | If the generation of @'YesodDispatch'@ instance require finer @@ -154,12 +156,13 @@ mkMDS rh = MkDispatchSettings -- hardly need this generality. However, in certain situations, like -- when writing library/plugin for yesod, this combinator becomes -- handy. -mkDispatchInstance :: Type -- ^ The master site type - -> Cxt -- ^ Context of the instance - -> [ResourceTree a] -- ^ The resource +mkDispatchInstance :: Type -- ^ The master site type + -> Cxt -- ^ Context of the instance + -> (Exp -> Q Exp) -- ^ Unwrap handler + -> [ResourceTree c] -- ^ The resource -> DecsQ -mkDispatchInstance master cxt res = do - clause' <- mkDispatchClause (mkMDS [|yesodRunner|]) res +mkDispatchInstance master cxt f res = do + clause' <- mkDispatchClause (mkMDS f [|yesodRunner|]) res let thisDispatch = FunD 'yesodDispatch [clause'] return [InstanceD cxt yDispatch [thisDispatch]] where @@ -167,7 +170,7 @@ mkDispatchInstance master cxt res = do mkYesodSubDispatch :: [ResourceTree a] -> Q Exp mkYesodSubDispatch res = do - clause' <- mkDispatchClause (mkMDS [|subHelper . fmap toTypedContent|]) res + clause' <- mkDispatchClause (mkMDS return [|subHelper . fmap toTypedContent|]) res inner <- newName "inner" let innerFun = FunD inner [clause'] helper <- newName "helper" diff --git a/yesod-core/Yesod/Routes/TH/Dispatch.hs b/yesod-core/Yesod/Routes/TH/Dispatch.hs index f073443f..f45789e2 100644 --- a/yesod-core/Yesod/Routes/TH/Dispatch.hs +++ b/yesod-core/Yesod/Routes/TH/Dispatch.hs @@ -13,10 +13,11 @@ import Control.Monad (forM) import Data.List (foldl') import Control.Arrow (second) import System.Random (randomRIO) +import Yesod.Core.Types (HandlerT) import Yesod.Routes.TH.Types import Data.Char (toLower) -data MkDispatchSettings = MkDispatchSettings +data MkDispatchSettings b site c = MkDispatchSettings { mdsRunHandler :: Q Exp , mdsSubDispatcher :: Q Exp , mdsGetPathInfo :: Q Exp @@ -25,6 +26,7 @@ data MkDispatchSettings = MkDispatchSettings , mds404 :: Q Exp , mds405 :: Q Exp , mdsGetHandler :: Maybe String -> String -> Q Exp + , mdsUnwrapper :: Exp -> Q Exp } data SDC = SDC @@ -39,7 +41,7 @@ data SDC = SDC -- view patterns. -- -- Since 1.4.0 -mkDispatchClause :: MkDispatchSettings -> [ResourceTree a] -> Q Clause +mkDispatchClause :: MkDispatchSettings b site c -> [ResourceTree a] -> Q Clause mkDispatchClause MkDispatchSettings {..} resources = do suffix <- qRunIO $ randomRIO (1000, 9999 :: Int) envName <- newName $ "env" ++ show suffix @@ -141,7 +143,7 @@ mkDispatchClause MkDispatchSettings {..} resources = do mkRunExp mmethod = do runHandlerE <- mdsRunHandler handlerE' <- mdsGetHandler mmethod name - let handlerE = foldl' AppE handlerE' allDyns + handlerE <- mdsUnwrapper $ foldl' AppE handlerE' allDyns return $ runHandlerE `AppE` handlerE `AppE` envExp diff --git a/yesod-core/Yesod/Routes/TH/ParseRoute.hs b/yesod-core/Yesod/Routes/TH/ParseRoute.hs index 1a4c29a8..7392b2ce 100644 --- a/yesod-core/Yesod/Routes/TH/ParseRoute.hs +++ b/yesod-core/Yesod/Routes/TH/ParseRoute.hs @@ -22,6 +22,7 @@ mkParseRouteInstance typ ress = do , mdsGetHandler = \_ _ -> [|error "mdsGetHandler"|] , mdsSetPathInfo = [|\p (_, q) -> (p, q)|] , mdsSubDispatcher = [|\_runHandler _getSub toMaster _env -> fmap toMaster . parseRoute|] + , mdsUnwrapper = return } (map removeMethods ress) helper <- newName "helper"