diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.4.18 + +* Add hook to apply arbitrary function to all handlers [#1122](https://github.com/yesodweb/yesod/pull/1122) + ## 1.4.17 * Add `getApprootText` diff --git a/Yesod/Core/Class/Yesod.hs b/Yesod/Core/Class/Yesod.hs --- a/Yesod/Core/Class/Yesod.hs +++ b/Yesod/Core/Class/Yesod.hs @@ -427,7 +427,7 @@ -- | Looks up the CSRF token from the request headers or POST parameters. If the value doesn't match the token stored in the session, -- this function throws a 'PermissionDenied' error. -- --- For details, see the "AJAX CSRF protection" section of 'Yesod.Core.Handler'. +-- For details, see the "AJAX CSRF protection" section of "Yesod.Core.Handler". -- -- Since 1.4.14 csrfCheckMiddleware :: Yesod site @@ -449,15 +449,15 @@ -- | Takes a 'SetCookie' and overrides its value with a CSRF token, then sets the cookie. See 'setCsrfCookieWithCookie'. -- --- For details, see the "AJAX CSRF protection" section of 'Yesod.Core.Handler'. +-- For details, see the "AJAX CSRF protection" section of "Yesod.Core.Handler". -- -- Since 1.4.14 csrfSetCookieMiddleware :: Yesod site => HandlerT site IO res -> SetCookie -> HandlerT site IO res csrfSetCookieMiddleware handler cookie = setCsrfCookieWithCookie cookie >> handler --- | Calls 'defaultCsrfSetCookieMiddleware' and 'defaultCsrfCheckMiddleware'. Use this midle +-- | Calls 'defaultCsrfSetCookieMiddleware' and 'defaultCsrfCheckMiddleware'. -- --- For details, see the "AJAX CSRF protection" section of 'Yesod.Core.Handler'. +-- For details, see the "AJAX CSRF protection" section of "Yesod.Core.Handler". -- -- Since 1.4.14 defaultCsrfMiddleware :: Yesod site => HandlerT site IO res -> HandlerT site IO res @@ -669,9 +669,9 @@ -- | Default formatting for log messages. When you use -- the template haskell logging functions for to log with information --- about the source location, that information will be appended to --- the end of the log. When you use the non-TH logging functions, --- like 'logDebugN', this function does not include source +-- about the source location, that information will be appended to +-- the end of the log. When you use the non-TH logging functions, +-- like 'logDebugN', this function does not include source -- information. This currently works by checking to see if the -- package name is the string \"\\". This is a hack, -- but it removes some of the visual clutter from non-TH logs. @@ -686,22 +686,22 @@ formatLogMessage getdate loc src level msg = do now <- getdate return $ mempty - `mappend` toLogStr now - `mappend` " [" + `mappend` toLogStr now + `mappend` " [" `mappend` (case level of LevelOther t -> toLogStr t - _ -> toLogStr $ drop 5 $ show level) + _ -> toLogStr $ drop 5 $ show level) `mappend` (if T.null src then mempty - else "#" `mappend` toLogStr src) - `mappend` "] " - `mappend` msg + else "#" `mappend` toLogStr src) + `mappend` "] " + `mappend` msg `mappend` sourceSuffix `mappend` "\n" - where + where sourceSuffix = if loc_package loc == "" then "" else mempty - `mappend` " @(" - `mappend` toLogStr (fileLocationToString loc) + `mappend` " @(" + `mappend` toLogStr (fileLocationToString loc) `mappend` ")" -- | Customize the cookies used by the session backend. You may diff --git a/Yesod/Core/Handler.hs b/Yesod/Core/Handler.hs --- a/Yesod/Core/Handler.hs +++ b/Yesod/Core/Handler.hs @@ -93,6 +93,8 @@ , sendFilePart , sendResponse , sendResponseStatus + -- ** Type specific response with custom status + , sendStatusJSON , sendResponseCreated , sendWaiResponse , sendWaiApplication @@ -198,6 +200,7 @@ ( extractBasicAuth, extractBearerAuth ) import Control.Monad.Trans.Class (lift) +import Data.Aeson (ToJSON(..)) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8With, encodeUtf8) import Data.Text.Encoding.Error (lenientDecode) @@ -319,7 +322,7 @@ getYesod :: MonadHandler m => m (HandlerSite m) getYesod = rheSite `liftM` askHandlerEnv --- | Get a specific component of the master site application argument. +-- | Get a specific component of the master site application argument. -- Analogous to the 'gets' function for operating on 'StateT'. getsYesod :: MonadHandler m => (HandlerSite m -> a) -> m a getsYesod f = (f . rheSite) `liftM` askHandlerEnv @@ -575,6 +578,11 @@ sendResponseStatus :: (MonadHandler m, ToTypedContent c) => H.Status -> c -> m a sendResponseStatus s = handlerError . HCContent s . toTypedContent +-- | Bypass remaining handler code and output the given JSON with the given +-- status code. +sendStatusJSON :: (MonadHandler m, ToJSON a) => H.Status -> a -> m a +sendStatusJSON s v = sendResponseStatus s (toJSON v) + -- | Send a 201 "Created" response with the given route as the Location -- response header. sendResponseCreated :: MonadHandler m => Route (HandlerSite m) -> m a @@ -1293,8 +1301,8 @@ } -- $ajaxCSRFOverview --- When a user has authenticated with your site, all requests made from the browser to your server will include the session information that you use to verify that the user is logged in. --- Unfortunately, this allows attackers to make unwanted requests on behalf of the user by e.g. submitting an HTTP request to your site when the user visits theirs. +-- When a user has authenticated with your site, all requests made from the browser to your server will include the session information that you use to verify that the user is logged in. +-- Unfortunately, this allows attackers to make unwanted requests on behalf of the user by e.g. submitting an HTTP request to your site when the user visits theirs. -- This is known as a (CSRF) attack. -- -- To combat this attack, you need a way to verify that the request is valid. @@ -1307,24 +1315,24 @@ -- -- (2) Yesod can store the CSRF token in a cookie which is accessible by Javascript. Requests made by Javascript can lookup this cookie and add it as a header to requests. The server then checks the token in the header against the one in the encrypted session. -- --- The form-based approach has the advantage of working for users with Javascript disabled, while adding the token to the headers with Javascript allows things like submitting JSON or binary data in AJAX requests. Yesod supports checking for a CSRF token in either the POST parameters of the form ('checkCsrfHeaderNamed'), the headers ('checkCsrfHeaderNamed'), or both options ('checkCsrfHeaderOrParam'). +-- The form-based approach has the advantage of working for users with Javascript disabled, while adding the token to the headers with Javascript allows things like submitting JSON or binary data in AJAX requests. Yesod supports checking for a CSRF token in either the POST parameters of the form ('checkCsrfParamNamed'), the headers ('checkCsrfHeaderNamed'), or both options ('checkCsrfHeaderOrParam'). -- -- The easiest way to check both sources is to add the 'defaultCsrfMiddleware' to your Yesod Middleware. -- | The default cookie name for the CSRF token ("XSRF-TOKEN"). --- +-- -- Since 1.4.14 defaultCsrfCookieName :: S8.ByteString defaultCsrfCookieName = "XSRF-TOKEN" -- | Sets a cookie with a CSRF token, using 'defaultCsrfCookieName' for the cookie name. --- +-- -- Since 1.4.14 setCsrfCookie :: MonadHandler m => m () setCsrfCookie = setCsrfCookieWithCookie def { setCookieName = defaultCsrfCookieName } -- | Takes a 'SetCookie' and overrides its value with a CSRF token, then sets the cookie. --- +-- -- Since 1.4.14 setCsrfCookieWithCookie :: MonadHandler m => SetCookie -> m () setCsrfCookieWithCookie cookie = do @@ -1332,14 +1340,14 @@ Fold.forM_ mCsrfToken (\token -> setCookie $ cookie { setCookieValue = encodeUtf8 token }) -- | The default header name for the CSRF token ("X-XSRF-TOKEN"). --- +-- -- Since 1.4.14 defaultCsrfHeaderName :: CI S8.ByteString defaultCsrfHeaderName = "X-XSRF-TOKEN" -- | Takes a header name to lookup a CSRF token. If the value doesn't match the token stored in the session, -- this function throws a 'PermissionDenied' error. --- +-- -- Since 1.4.14 checkCsrfHeaderNamed :: MonadHandler m => CI S8.ByteString -> m () checkCsrfHeaderNamed headerName = do @@ -1347,7 +1355,7 @@ unless valid (permissionDenied csrfErrorMessage) -- | Takes a header name to lookup a CSRF token, and returns whether the value matches the token stored in the session. --- +-- -- Since 1.4.14 hasValidCsrfHeaderNamed :: MonadHandler m => CI S8.ByteString -> m Bool hasValidCsrfHeaderNamed headerName = do diff --git a/Yesod/Core/Internal.hs b/Yesod/Core/Internal.hs --- a/Yesod/Core/Internal.hs +++ b/Yesod/Core/Internal.hs @@ -5,3 +5,4 @@ ) where import Yesod.Core.Internal.Request as X (randomString, parseWaiRequest) +import Yesod.Core.Internal.TH as X (mkYesodGeneral) diff --git a/Yesod/Core/Internal/TH.hs b/Yesod/Core/Internal/TH.hs --- a/Yesod/Core/Internal/TH.hs +++ b/Yesod/Core/Internal/TH.hs @@ -32,13 +32,13 @@ 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 @@ 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 @@ -- | '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 @@ 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 @@ ] 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 @@ , mds404 = [|notFound >> return ()|] , mds405 = [|badMethod >> return ()|] , mdsGetHandler = defaultGetHandler + , mdsUnwrapper = f } -- | If the generation of @'YesodDispatch'@ instance require finer @@ -154,12 +156,13 @@ -- 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 @@ 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/Routes/TH/Dispatch.hs b/Yesod/Routes/TH/Dispatch.hs --- a/Yesod/Routes/TH/Dispatch.hs +++ b/Yesod/Routes/TH/Dispatch.hs @@ -16,7 +16,7 @@ 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 +25,7 @@ , mds404 :: Q Exp , mds405 :: Q Exp , mdsGetHandler :: Maybe String -> String -> Q Exp + , mdsUnwrapper :: Exp -> Q Exp } data SDC = SDC @@ -39,7 +40,7 @@ -- 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 +142,7 @@ 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/Routes/TH/ParseRoute.hs b/Yesod/Routes/TH/ParseRoute.hs --- a/Yesod/Routes/TH/ParseRoute.hs +++ b/Yesod/Routes/TH/ParseRoute.hs @@ -22,6 +22,7 @@ , mdsGetHandler = \_ _ -> [|error "mdsGetHandler"|] , mdsSetPathInfo = [|\p (_, q) -> (p, q)|] , mdsSubDispatcher = [|\_runHandler _getSub toMaster _env -> fmap toMaster . parseRoute|] + , mdsUnwrapper = return } (map removeMethods ress) helper <- newName "helper" diff --git a/test/Hierarchy.hs b/test/Hierarchy.hs --- a/test/Hierarchy.hs +++ b/test/Hierarchy.hs @@ -119,6 +119,7 @@ , mds404 = [|pack "404"|] , mds405 = [|pack "405"|] , mdsGetHandler = defaultGetHandler + , mdsUnwrapper = return } resources return $ InstanceD diff --git a/test/RouteSpec.hs b/test/RouteSpec.hs --- a/test/RouteSpec.hs +++ b/test/RouteSpec.hs @@ -92,6 +92,7 @@ , mds404 = [|pack "404"|] , mds405 = [|pack "405"|] , mdsGetHandler = defaultGetHandler + , mdsUnwrapper = return } ress return $ InstanceD @@ -294,6 +295,17 @@ /!#foo Foo5 |] findOverlapNames routes @?= [] + it "detects overlaps in a hierarchy" $ do + let routes = [parseRoutesNoCheck| +/foo/before FooBeforeR GET +/foo/nested FooSlashNestedR GET +/foo FooR: + /nested FooNestedR GET +/foo/after FooAfterR GET +|] + findOverlapNames routes @?= + [ ("FooSlashNestedR", "") + ] it "proper boolean logic" $ do let routes = [parseRoutesNoCheck| /foo/bar Foo1 diff --git a/yesod-core.cabal b/yesod-core.cabal --- a/yesod-core.cabal +++ b/yesod-core.cabal @@ -1,5 +1,5 @@ name: yesod-core -version: 1.4.17 +version: 1.4.18 license: MIT license-file: LICENSE author: Michael Snoyman