From 80509735d55c9113752d1920e1ceae96b06420fa Mon Sep 17 00:00:00 2001 From: Amitai Burstein Date: Mon, 31 Jul 2023 21:33:39 +0300 Subject: [PATCH] Add custom 403 response (#1736) * Add custom 403 response * Add renderAccessDenied * Try to import * Try to move to IHP/Controller/Render.hs * Start separating modules * More wiring * More wiring * Revert comment out * Add tood * More changes * Fixed tests (#3) * Expose controller * More wiring * Remove todo * Add IHP.Controller.Response * Apply suggestions from code review Co-authored-by: Marc Scholten * Code review fixes * Add to prelude * Fix CookieSpec.hs test * Remove wrong line break * Add tests * Fix copy paste * Fix error * Add missing IHP.Controller.Response * Update docs * Remove wrong import * Another fix * Update docs * More fixes by the compiler --------- Co-authored-by: Marc Scholten --- Guide/recipes.markdown | 8 +- Guide/routing.markdown | 4 +- IHP/AuthSupport/Authorization.hs | 40 ------ IHP/AutoRefresh.hs | 1 + IHP/Controller/AccessDenied.hs | 159 +++++++++++++++++++++++ IHP/Controller/NotFound.hs | 159 +++++++++++++++++++++++ IHP/Controller/Render.hs | 17 +-- IHP/Controller/Response.hs | 52 ++++++++ IHP/ControllerPrelude.hs | 4 + IHP/ControllerSupport.hs | 45 +------ IHP/ErrorController.hs | 102 +-------------- IHP/IDE/Data/Controller.hs | 13 +- IHP/IDE/ToolServer.hs | 3 +- IHP/LoginSupport/Helper/Controller.hs | 2 - IHP/Server.hs | 12 +- IHP/ValidationSupport.hs | 2 - IHP/ValidationSupport/ValidateCanView.hs | 55 -------- Test/Controller/AccessDeniedSpec.hs | 93 +++++++++++++ Test/Controller/CookieSpec.hs | 5 +- Test/Controller/NotFoundSpec.hs | 93 +++++++++++++ Test/Main.hs | 4 + Test/RouterSupportSpec.hs | 4 +- Test/SEO/Sitemap.hs | 4 +- Test/ViewSupportSpec.hs | 2 +- ihp.cabal | 5 +- 25 files changed, 607 insertions(+), 281 deletions(-) delete mode 100644 IHP/AuthSupport/Authorization.hs create mode 100644 IHP/Controller/AccessDenied.hs create mode 100644 IHP/Controller/NotFound.hs create mode 100644 IHP/Controller/Response.hs delete mode 100644 IHP/ValidationSupport/ValidateCanView.hs create mode 100644 Test/Controller/AccessDeniedSpec.hs create mode 100644 Test/Controller/NotFoundSpec.hs diff --git a/Guide/recipes.markdown b/Guide/recipes.markdown index ce66b54ab..b2575fa1c 100644 --- a/Guide/recipes.markdown +++ b/Guide/recipes.markdown @@ -133,7 +133,7 @@ instance View EditView where ## Checking that the current user has permission to access the action -Use [accessDeniedWhen](https://ihp.digitallyinduced.com/api-docs/IHP-LoginSupport-Helper-Controller.html#v:accessDeniedWhen) like this: +Use [accessDeniedWhen](https://ihp.digitallyinduced.com/api-docs/IHP-Controller-AccessDenied.html#v:accessDeniedWhen) like this: ```haskell action EditPostAction { postId } = do @@ -144,7 +144,7 @@ action EditPostAction { postId } = do renderHtml EditView { .. } ``` -Or the opposite command [accessDeniedUnless](https://ihp.digitallyinduced.com/api-docs/IHP-LoginSupport-Helper-Controller.html#v:accessDeniedUnless) like this: +Or the opposite command [accessDeniedUnless](https://ihp.digitallyinduced.com/api-docs/IHP-Controller-AccessDenied.html#v:accessDeniedUnless) like this: ```haskell action EditPostAction { postId } = do @@ -155,6 +155,10 @@ action EditPostAction { postId } = do renderHtml EditView { .. } ``` +Sometimes you'd want to hide the fact a resource exists at all. For example, if a user is not allowed to see a other users, you might want to show a page not found instead of an access denied page. You can do this with [notFoundWhen](https://ihp.digitallyinduced.com/api-docs/IHP-Controller-NotFound.html#v:notFoundWhen) and [notFoundUnless](https://ihp.digitallyinduced.com/api-docs/IHP-Controller-NotFound.html#v:notFoundUnless). + +```haskell + ## Creating a custom validator If needed you can just write your constraint, e.g. like this: diff --git a/Guide/routing.markdown b/Guide/routing.markdown index ac5d85033..34eb76f77 100644 --- a/Guide/routing.markdown +++ b/Guide/routing.markdown @@ -297,6 +297,6 @@ instance HasPath RegistrationsController where HTML forms don't support special HTTP methods like `DELETE`. To work around this issue, IHP has [a middleware](https://hackage.haskell.org/package/wai-extra-3.0.1/docs/Network-Wai-Middleware-MethodOverridePost.html) which transforms e.g. a `POST` request with a form field `_method` set to `DELETE` to a `DELETE` request. -## Custom 404 Page +## Custom 403 and 404 pages -You can override the default IHP 404 Not Found error page by creating a new file at `static/404.html`. Then IHP will render that HTML file instead of displaying the default IHP not found page. +You can override the default 403 access denied and the default 404 not found pagesby creating a new file at `static/403.html` and `static/404.html`. Then IHP will render that HTML file instead of displaying the default IHP page. diff --git a/IHP/AuthSupport/Authorization.hs b/IHP/AuthSupport/Authorization.hs deleted file mode 100644 index 2baa5fb91..000000000 --- a/IHP/AuthSupport/Authorization.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-| -Module: IHP.AuthSupport.Authorization -Description: Building blocks to provide authorization to your application -Copyright: (c) digitally induced GmbH, 2020 --} -module IHP.AuthSupport.Authorization where - -import IHP.Prelude - -class CanView user model where - canView :: (?modelContext :: ModelContext) => model -> user -> IO Bool - --- | Stops the action execution with an error message when the access condition is True. --- --- __Example:__ Checking a user is the author of a blog post. --- --- > action EditPostAction { postId } = do --- > post <- fetch postId --- > accessDeniedWhen (post.authorId /= currentUserId) --- > --- > renderHtml EditView { .. } --- --- This will throw an error and prevent the view from being rendered when the current user is not the author of the post. -accessDeniedWhen :: Bool -> IO () -accessDeniedWhen condition = when condition (fail "Access denied") - --- | Stops the action execution with an error message when the access condition is False. --- --- __Example:__ Checking a user is the author of a blog post. --- --- > action EditPostAction { postId } = do --- > post <- fetch postId --- > accessDeniedUnless (post.authorId == currentUserId) --- > --- > renderHtml EditView { .. } --- --- This will throw an error and prevent the view from being rendered when the current user is not the author of the post. -accessDeniedUnless :: Bool -> IO () -accessDeniedUnless condition = unless condition (fail "Access denied") - diff --git a/IHP/AutoRefresh.hs b/IHP/AutoRefresh.hs index a03475dc5..d37fb0f87 100644 --- a/IHP/AutoRefresh.hs +++ b/IHP/AutoRefresh.hs @@ -22,6 +22,7 @@ import qualified Data.Maybe as Maybe import qualified Data.Text as Text import IHP.WebSocket import IHP.Controller.Context +import IHP.Controller.Response import qualified IHP.PGListener as PGListener import qualified Database.PostgreSQL.Simple.Types as PG import Data.String.Interpolate.IsString diff --git a/IHP/Controller/AccessDenied.hs b/IHP/Controller/AccessDenied.hs new file mode 100644 index 000000000..abe1c9c9f --- /dev/null +++ b/IHP/Controller/AccessDenied.hs @@ -0,0 +1,159 @@ +module IHP.Controller.AccessDenied +( accessDeniedWhen +, accessDeniedUnless +, handleAccessDeniedFound +, buildAccessDeniedResponse +, renderAccessDenied +) +where + +import IHP.Prelude hiding (displayException) +import IHP.Controller.RequestContext +import Network.HTTP.Types (status403) +import Network.Wai +import Network.HTTP.Types.Header +import qualified Text.Blaze.Html.Renderer.Utf8 as Blaze +import qualified Data.ByteString.Lazy as LBS +import IHP.HSX.QQ (hsx) +import qualified System.Directory as Directory +import IHP.Controller.Context +import IHP.Controller.Response (respondAndExit) + + +-- | Stops the action execution with an access denied message (403) when the access condition is True. +-- +-- __Example:__ Checking a user is the author of a blog post. +-- +-- > action EditPostAction { postId } = do +-- > post <- fetch postId +-- > accessDeniedWhen (post.authorId /= currentUserId) +-- > +-- > renderHtml EditView { .. } +-- +-- This will throw an error and prevent the view from being rendered when the current user is not the author of the post. +accessDeniedWhen :: (?context :: ControllerContext) => Bool -> IO () +accessDeniedWhen condition = when condition renderAccessDenied + +-- | Stops the action execution with an access denied message (403) when the access condition is False. +-- +-- __Example:__ Checking a user is the author of a blog post. +-- +-- > action EditPostAction { postId } = do +-- > post <- fetch postId +-- > accessDeniedUnless (post.authorId == currentUserId) +-- > +-- > renderHtml EditView { .. } +-- +-- This will throw an error and prevent the view from being rendered when the current user is not the author of the post. +accessDeniedUnless :: (?context :: ControllerContext) => Bool -> IO () +accessDeniedUnless condition = unless condition renderAccessDenied + +-- | Renders a 403 access denied response. If a static/403.html exists, that is rendered instead of the IHP access denied page. +handleAccessDeniedFound :: Request -> Respond -> IO ResponseReceived +handleAccessDeniedFound request respond = do + response <- buildAccessDeniedResponse + respond response + +buildAccessDeniedResponse :: IO Response +buildAccessDeniedResponse = do + hasCustomAccessDenied <- Directory.doesFileExist "static/403.html" + if hasCustomAccessDenied + then customAccessDeniedResponse + else pure defaultAccessDeniedResponse + +-- | The default IHP 403 not found page +defaultAccessDeniedResponse :: Response +defaultAccessDeniedResponse = responseBuilder status403 [(hContentType, "text/html")] $ Blaze.renderHtmlBuilder [hsx| + + + + + + + Access denied + + + +
+ + + + + + + + + + + + + + + + + + +
+

Error 403

+

Access denied

+
+ + + |] + +-- | Renders the static/403.html file +customAccessDeniedResponse :: IO Response +customAccessDeniedResponse = do + -- We cannot use responseFile here as responseFile ignore the status code by default + -- + -- See https://github.com/yesodweb/wai/issues/644 + page <- LBS.readFile "static/403.html" + pure $ responseLBS status403 [(hContentType, "text/html")] page + + +-- | Renders an "Access denied" page. +-- +-- This can be useful e.g. when an entity cannot be accessed: +-- +-- > action ExampleAction = do +-- > renderAccessDenied +-- +-- You can override the default access denied page by creating a new file at @static/403.html@. Then IHP will render that HTML file instead of displaying the default IHP access denied page. +-- +renderAccessDenied :: (?context :: ControllerContext) => IO () +renderAccessDenied = do + response <- buildAccessDeniedResponse + respondAndExit response \ No newline at end of file diff --git a/IHP/Controller/NotFound.hs b/IHP/Controller/NotFound.hs new file mode 100644 index 000000000..0d81a41e2 --- /dev/null +++ b/IHP/Controller/NotFound.hs @@ -0,0 +1,159 @@ +module IHP.Controller.NotFound +( notFoundWhen +, notFoundUnless +, handleNotFound +, buildNotFoundResponse +, renderNotFound +) + where + +import IHP.Prelude hiding (displayException) +import IHP.Controller.RequestContext +import Network.HTTP.Types (status404) +import Network.Wai +import Network.HTTP.Types.Header +import qualified Text.Blaze.Html.Renderer.Utf8 as Blaze +import qualified Data.ByteString.Lazy as LBS +import IHP.HSX.QQ (hsx) +import qualified System.Directory as Directory +import IHP.Controller.Context +import IHP.Controller.Response (respondAndExit) + + +-- | Stops the action execution with a not found message (404) when the access condition is True. +-- +-- __Example:__ Checking a user is the author of a blog post. +-- +-- > action EditPostAction { postId } = do +-- > post <- fetch postId +-- > notFoundWhen (post.authorId /= currentUserId) +-- > +-- > renderHtml EditView { .. } +-- +-- This will throw an error and prevent the view from being rendered when the current user is not the author of the post. +notFoundWhen :: (?context :: ControllerContext) => Bool -> IO () +notFoundWhen condition = when condition renderNotFound + +-- | Stops the action execution with a not found message (404) when the access condition is False. +-- +-- __Example:__ Checking a user is the author of a blog post. +-- +-- > action EditPostAction { postId } = do +-- > post <- fetch postId +-- > notFoundUnless (post.authorId == currentUserId) +-- > +-- > renderHtml EditView { .. } +-- +-- This will throw an error and prevent the view from being rendered when the current user is not the author of the post. +notFoundUnless :: (?context :: ControllerContext) => Bool -> IO () +notFoundUnless condition = unless condition renderNotFound + + +-- | Renders a 404 not found response. If a static/404.html exists, that is rendered instead of the IHP not found page +handleNotFound :: Request -> Respond -> IO ResponseReceived +handleNotFound request respond = do + response <- buildNotFoundResponse + respond response + +buildNotFoundResponse :: IO Response +buildNotFoundResponse = do + hasCustomNotFound <- Directory.doesFileExist "static/404.html" + if hasCustomNotFound + then customNotFoundResponse + else pure defaultNotFoundResponse + +-- | The default IHP 404 not found page +defaultNotFoundResponse :: Response +defaultNotFoundResponse = responseBuilder status404 [(hContentType, "text/html")] $ Blaze.renderHtmlBuilder [hsx| + + + + + + + Action not found + + + +
+ + + + + + + + + + + + + + + + + + +
+

Error 404

+

Action not found

+
+ + + |] + +-- | Renders the static/404.html file +customNotFoundResponse :: IO Response +customNotFoundResponse = do + -- We cannot use responseFile here as responseFile ignore the status code by default + -- + -- See https://github.com/yesodweb/wai/issues/644 + page <- LBS.readFile "static/404.html" + pure $ responseLBS status404 [(hContentType, "text/html")] page + +-- | Renders an "Not found" page. +-- +-- This can be useful e.g. when an entity cannot be accessed: +-- +-- > action ExampleAction = do +-- > renderNotFound +-- +-- You can override the default access denied page by creating a new file at @static/403.html@. Then IHP will render that HTML file instead of displaying the default IHP access denied page. +-- +renderNotFound :: (?context :: ControllerContext) => IO () +renderNotFound = do + response <- buildNotFoundResponse + respondAndExit response \ No newline at end of file diff --git a/IHP/Controller/Render.hs b/IHP/Controller/Render.hs index cb7731204..7c36aef88 100644 --- a/IHP/Controller/Render.hs +++ b/IHP/Controller/Render.hs @@ -19,7 +19,6 @@ import IHP.Controller.Layout import qualified IHP.FrameworkConfig as FrameworkConfig import qualified Data.ByteString.Builder as ByteString import IHP.FlashMessages.ControllerFunctions (initFlashMessages) -import qualified IHP.ErrorController as ErrorController renderPlain :: (?context :: ControllerContext) => LByteString -> IO () renderPlain text = respondAndExit $ responseLBS status200 [(hContentType, "text/plain")] text @@ -89,20 +88,6 @@ renderJson' :: (?context :: ControllerContext) => ResponseHeaders -> Data.Aeson. renderJson' additionalHeaders json = respondAndExit $ responseLBS status200 ([(hContentType, "application/json")] <> additionalHeaders) (Data.Aeson.encode json) {-# INLINABLE renderJson' #-} --- | Render's a generic not found page --- --- This can be useful e.g. when an entity cannot be found: --- --- > action ExampleAction = do --- > renderNotFound --- --- You can override the default not found error page by creating a new file at @static/404.html@. Then IHP will render that HTML file instead of displaying the default IHP not found page. --- -renderNotFound :: (?context :: ControllerContext) => IO () -renderNotFound = do - response <- ErrorController.buildNotFoundResponse - respondAndExit response - data PolymorphicRender = PolymorphicRender { html :: Maybe (IO ()) @@ -111,7 +96,7 @@ data PolymorphicRender -- | Can be used to render different responses for html, json, etc. requests based on `Accept` header -- Example: --- +-- -- > show :: Action -- > show = do -- > renderPolymorphic polymorphicRender { diff --git a/IHP/Controller/Response.hs b/IHP/Controller/Response.hs new file mode 100644 index 000000000..5a79af936 --- /dev/null +++ b/IHP/Controller/Response.hs @@ -0,0 +1,52 @@ +module IHP.Controller.Response +( respondAndExit +, addResponseHeaders +, addResponseHeadersFromContext +, ResponseException (..) +) +where + +import ClassyPrelude +import Network.HTTP.Types.Header +import qualified IHP.Controller.Context as Context +import IHP.Controller.Context (ControllerContext(ControllerContext)) +import qualified Network.Wai +import Network.Wai (Response) +import qualified Control.Exception as Exception + +respondAndExit :: (?context::ControllerContext) => Response -> IO () +respondAndExit response = do + responseWithHeaders <- addResponseHeadersFromContext response + Exception.throwIO (ResponseException responseWithHeaders) +{-# INLINE respondAndExit #-} + +-- | Add headers to current response +-- | Returns a Response with headers +-- +-- > addResponseHeaders [("Content-Type", "text/html")] response +-- +addResponseHeaders :: [Header] -> Response -> Response +addResponseHeaders headers = Network.Wai.mapResponseHeaders (\hs -> headers <> hs) +{-# INLINABLE addResponseHeaders #-} + +-- | Add headers to current response, getting the headers from ControllerContext +-- | Returns a Response with headers +-- +-- > addResponseHeadersFromContext response +-- You probabaly want `setHeader` +-- +addResponseHeadersFromContext :: (?context :: ControllerContext) => Response -> IO Response +addResponseHeadersFromContext response = do + maybeHeaders <- Context.maybeFromContext @[Header] + let headers = fromMaybe [] maybeHeaders + let responseWithHeaders = addResponseHeaders headers response + pure responseWithHeaders +{-# INLINABLE addResponseHeadersFromContext #-} + +-- Can be thrown from inside the action to abort the current action execution. +-- Does not indicates a runtime error. It's just used for control flow management. +newtype ResponseException = ResponseException Response + +instance Show ResponseException where show _ = "ResponseException { .. }" + +instance Exception ResponseException \ No newline at end of file diff --git a/IHP/ControllerPrelude.hs b/IHP/ControllerPrelude.hs index d7c0e8956..75892b643 100644 --- a/IHP/ControllerPrelude.hs +++ b/IHP/ControllerPrelude.hs @@ -1,6 +1,8 @@ module IHP.ControllerPrelude ( module IHP.Prelude , module IHP.ControllerSupport + , module IHP.Controller.AccessDenied + , module IHP.Controller.NotFound , module IHP.Controller.Render , module IHP.Controller.Param , module IHP.Controller.FileUpload @@ -41,6 +43,8 @@ import IHP.Prelude import IHP.Controller.Param import IHP.Controller.FileUpload import IHP.Controller.Render +import IHP.Controller.AccessDenied +import IHP.Controller.NotFound import IHP.Controller.Session import IHP.Controller.RequestContext import IHP.Controller.BasicAuth diff --git a/IHP/ControllerSupport.hs b/IHP/ControllerSupport.hs index 037870279..121e1adb0 100644 --- a/IHP/ControllerSupport.hs +++ b/IHP/ControllerSupport.hs @@ -19,14 +19,11 @@ module IHP.ControllerSupport , runActionWithNewContext , newContextForAction , respondAndExit -, ResponseException (..) , jumpToAction , requestBodyJSON , startWebSocketApp , startWebSocketAppAndFailOnHTTP , setHeader -, addResponseHeaders -, addResponseHeadersFromContext , getAppConfig ) where @@ -48,6 +45,7 @@ import qualified Data.Typeable as Typeable import IHP.FrameworkConfig (FrameworkConfig (..), ConfigProvider(..)) import qualified IHP.Controller.Context as Context import IHP.Controller.Context (ControllerContext(ControllerContext), customFieldsRef) +import IHP.Controller.Response import Network.HTTP.Types.Header import qualified Data.Aeson as Aeson import qualified Network.Wai.Handler.WebSockets as WebSockets @@ -231,29 +229,6 @@ setHeader header = do Context.putContext (header : headers) {-# INLINABLE setHeader #-} --- | Add headers to current response --- | Returns a Response with headers --- --- > addResponseHeaders [("Content-Type", "text/html")] response --- -addResponseHeaders :: [Header] -> Response -> Response -addResponseHeaders headers = Network.Wai.mapResponseHeaders (\hs -> headers <> hs) -{-# INLINABLE addResponseHeaders #-} - --- | Add headers to current response, getting the headers from ControllerContext --- | Returns a Response with headers --- --- > addResponseHeadersFromContext response --- You probabaly want `setHeader` --- -addResponseHeadersFromContext :: (?context :: ControllerContext) => Response -> IO Response -addResponseHeadersFromContext response = do - maybeHeaders <- Context.maybeFromContext @[Header] - let headers = fromMaybe [] maybeHeaders - let responseWithHeaders = addResponseHeaders headers response - pure responseWithHeaders -{-# INLINABLE addResponseHeadersFromContext #-} - -- | Returns the current HTTP request. -- -- See https://hackage.haskell.org/package/wai-3.2.2.1/docs/Network-Wai.html#t:Request @@ -293,19 +268,6 @@ createRequestContext ApplicationContext { session, frameworkConfig } request res pure RequestContext.RequestContext { request, respond, requestBody, vault = session, frameworkConfig } --- Can be thrown from inside the action to abort the current action execution. --- Does not indicates a runtime error. It's just used for control flow management. -newtype ResponseException = ResponseException Response - -instance Show ResponseException where show _ = "ResponseException { .. }" - -instance Exception ResponseException - -respondAndExit :: (?context::ControllerContext) => Response -> IO () -respondAndExit response = do - responseWithHeaders <- addResponseHeadersFromContext response - Exception.throwIO (ResponseException responseWithHeaders) -{-# INLINE respondAndExit #-} -- | Returns a custom config parameter -- @@ -324,12 +286,12 @@ respondAndExit response = do -- > -- ... -- > stripePublicKey <- StripePublicKey <$> env @Text "STRIPE_PUBLIC_KEY" -- > option stripePublicKey --- +-- -- Then you can access it using 'getAppConfig': -- -- > action MyAction = do -- > let (StripePublicKey stripePublicKey) = getAppConfig @StripePublicKey --- > +-- > -- > putStrLn ("Stripe public key: " <> stripePublicKey) -- getAppConfig :: forall configParameter context. (?context :: context, ConfigProvider context, Typeable configParameter) => configParameter @@ -337,3 +299,4 @@ getAppConfig = ?context.frameworkConfig.appConfig |> TypeMap.lookup @configParameter |> fromMaybe (error ("Could not find " <> (show (Typeable.typeRep (Typeable.Proxy @configParameter))) <>" in config")) {-# INLINE getAppConfig #-} + diff --git a/IHP/ErrorController.hs b/IHP/ErrorController.hs index 2e8d3ca34..29b84d9b8 100644 --- a/IHP/ErrorController.hs +++ b/IHP/ErrorController.hs @@ -6,9 +6,7 @@ Copyright: (c) digitally induced GmbH, 2020 module IHP.ErrorController ( displayException , handleNoResponseReturned -, handleNotFound , handleRouterException -, buildNotFoundResponse ) where import IHP.Prelude hiding (displayException) @@ -18,7 +16,7 @@ import qualified Network.HTTP.Types.Method as Router import qualified Control.Exception as Exception import qualified Data.Text as Text import IHP.Controller.RequestContext -import Network.HTTP.Types (status500, status404, status400) +import Network.HTTP.Types (status500, status404, status400, status403) import Network.Wai import Network.HTTP.Types.Header @@ -35,6 +33,7 @@ import qualified IHP.Environment as Environment import IHP.Controller.Context import qualified System.Directory as Directory import IHP.ApplicationContext +import IHP.Controller.NotFound (handleNotFound) handleNoResponseReturned :: (Show controller, ?context :: ControllerContext) => controller -> IO ResponseReceived handleNoResponseReturned controller = do @@ -51,101 +50,6 @@ handleNoResponseReturned controller = do let RequestContext { respond } = ?context.requestContext respond $ responseBuilder status500 [(hContentType, "text/html")] (Blaze.renderHtmlBuilder (renderError title errorMessage)) --- | Renders a 404 not found response. If a static/404.html exists, that is rendered instead of the IHP not found page -handleNotFound :: Request -> Respond -> IO ResponseReceived -handleNotFound request respond = do - response <- buildNotFoundResponse - respond response - -buildNotFoundResponse :: IO Response -buildNotFoundResponse = do - hasCustomNotFound <- Directory.doesFileExist "static/404.html" - if hasCustomNotFound - then customNotFoundResponse - else pure defaultNotFoundResponse - --- | The default IHP 404 not found page -defaultNotFoundResponse :: Response -defaultNotFoundResponse = responseBuilder status404 [(hContentType, "text/html")] $ Blaze.renderHtmlBuilder [hsx| - - - - - - - Action not found - - - -
- - - - - - - - - - - - - - - - - - -
-

Error 404

-

Action not found

-
- - - |] - --- | Renders the static/404.html file -customNotFoundResponse :: IO Response -customNotFoundResponse = do - -- We cannot use responseFile here as responseFile ignore the status code by default - -- - -- See https://github.com/yesodweb/wai/issues/644 - page <- LBS.readFile "static/404.html" - pure $ responseLBS status404 [(hContentType, "text/html")] page - displayException :: (Show action, ?context :: ControllerContext, ?applicationContext :: ApplicationContext, ?requestContext :: RequestContext) => SomeException -> action -> Text -> IO ResponseReceived displayException exception action additionalInfo = do -- Dev handlers display helpful tips on how to resolve the problem @@ -257,7 +161,7 @@ postgresHandler exception controller additionalInfo = do | "relation" `ByteString.isPrefixOf` (sqlError.sqlErrorMsg) && "does not exist" `ByteString.isSuffixOf` (sqlError.sqlErrorMsg) -> Just (handlePostgresOutdatedError exception "A table is missing.") - + -- Catching `columns "..." does not exist` Just exception@ModelSupport.EnhancedSqlError { sqlError } | "column" `ByteString.isPrefixOf` (sqlError.sqlErrorMsg) diff --git a/IHP/IDE/Data/Controller.hs b/IHP/IDE/Data/Controller.hs index 0b55bf5b9..2c292ae27 100644 --- a/IHP/IDE/Data/Controller.hs +++ b/IHP/IDE/Data/Controller.hs @@ -1,6 +1,7 @@ module IHP.IDE.Data.Controller where import IHP.ControllerPrelude +import IHP.Controller.NotFound import IHP.IDE.ToolServer.Types import IHP.IDE.Data.View.ShowDatabase import IHP.IDE.Data.View.ShowTableRows @@ -172,9 +173,9 @@ instance Controller DataController where case foreignKeyInfo of Just (foreignTable, foreignColumn) -> Just <$> fetchRowsPage connection foreignTable 1 50 Nothing -> pure Nothing - + PG.close connection - + case rows of Just rows -> renderJson rows Nothing -> renderNotFound @@ -280,9 +281,9 @@ fetchForeignKeyInfo connection tableName columnName = do let sql = [plain| SELECT ccu.table_name AS foreign_table_name, - ccu.column_name AS foreign_column_name - FROM - information_schema.table_constraints AS tc + ccu.column_name AS foreign_column_name + FROM + information_schema.table_constraints AS tc JOIN information_schema.key_column_usage AS kcu ON tc.constraint_name = kcu.constraint_name AND tc.table_schema = kcu.table_schema @@ -295,7 +296,7 @@ fetchForeignKeyInfo connection tableName columnName = do AND kcu.column_name = ? |] let args = (tableName, columnName) - result <- PG.query connection (PG.Query $ cs sql) args + result <- PG.query connection (PG.Query $ cs sql) args case result of [(foreignTableName, foreignColumnName)] -> pure $ Just (foreignTableName, foreignColumnName) otherwise -> pure $ Nothing diff --git a/IHP/IDE/ToolServer.hs b/IHP/IDE/ToolServer.hs index 302b7294c..722d58478 100644 --- a/IHP/IDE/ToolServer.hs +++ b/IHP/IDE/ToolServer.hs @@ -47,6 +47,7 @@ import qualified IHP.PGListener as PGListener import qualified Network.Wai.Application.Static as Static import qualified WaiAppStatic.Types as Static +import IHP.Controller.NotFound (handleNotFound) withToolServer :: (?context :: Context) => IO () -> IO () withToolServer inner = withAsyncBound async (\_ -> inner) @@ -104,7 +105,7 @@ initStaticApp :: IO Wai.Application initStaticApp = do libDirectory <- cs <$> LibDir.findLibDirectory let staticSettings = (Static.defaultWebAppSettings (libDirectory <> "static/")) - { Static.ss404Handler = Just ErrorController.handleNotFound + { Static.ss404Handler = Just handleNotFound , Static.ssMaxAge = Static.MaxAgeSeconds (60 * 60 * 24 * 30) -- 30 days } pure (Static.staticApp staticSettings) diff --git a/IHP/LoginSupport/Helper/Controller.hs b/IHP/LoginSupport/Helper/Controller.hs index c3e0242d3..391487bb1 100644 --- a/IHP/LoginSupport/Helper/Controller.hs +++ b/IHP/LoginSupport/Helper/Controller.hs @@ -15,7 +15,6 @@ module IHP.LoginSupport.Helper.Controller , logout , CurrentUserRecord , CurrentAdminRecord -, module IHP.AuthSupport.Authorization , module IHP.AuthSupport.Authentication , enableRowLevelSecurityIfLoggedIn , currentRoleOrNothing @@ -33,7 +32,6 @@ import IHP.FlashMessages.ControllerFunctions import qualified IHP.ModelSupport as ModelSupport import IHP.ControllerSupport import System.IO.Unsafe (unsafePerformIO) -import IHP.AuthSupport.Authorization import IHP.AuthSupport.Authentication import IHP.Controller.Context import qualified IHP.FrameworkConfig as FrameworkConfig diff --git a/IHP/Server.hs b/IHP/Server.hs index c40b7eb58..ed93305a6 100644 --- a/IHP/Server.hs +++ b/IHP/Server.hs @@ -16,7 +16,7 @@ import qualified IHP.PGListener as PGListener import IHP.FrameworkConfig import IHP.RouterSupport (frontControllerToWAIApp, FrontController, webSocketApp, webSocketAppWithCustomPath) -import qualified IHP.ErrorController as ErrorController +import IHP.ErrorController import qualified IHP.AutoRefresh as AutoRefresh import qualified IHP.AutoRefresh.Types as AutoRefresh import IHP.LibDir @@ -34,6 +34,8 @@ import qualified Network.Wai.Application.Static as Static import qualified WaiAppStatic.Types as Static import qualified IHP.EnvVar as EnvVar +import IHP.Controller.NotFound (handleNotFound) + run :: (FrontController RootApplication, Job.Worker RootApplication) => ConfigBuilder -> IO () run configBuilder = do -- We cannot use 'Main.Utf8.withUtf8' here, as this for some reason breaks live reloading @@ -59,13 +61,13 @@ run configBuilder = do let requestLoggerMiddleware = frameworkConfig.requestLoggerMiddleware let CustomMiddleware customMiddleware = frameworkConfig.customMiddleware - withBackgroundWorkers pgListener frameworkConfig + withBackgroundWorkers pgListener frameworkConfig . runServer frameworkConfig . customMiddleware . corsMiddleware . sessionMiddleware . requestLoggerMiddleware - . methodOverridePost + . methodOverridePost $ application staticApp {-# INLINABLE run #-} @@ -94,10 +96,10 @@ initStaticApp frameworkConfig = do Env.Development -> Static.MaxAgeSeconds 0 Env.Production -> Static.MaxAgeForever - + frameworkStaticDir = libDir <> "/static/" frameworkSettings = (Static.defaultWebAppSettings frameworkStaticDir) - { Static.ss404Handler = Just ErrorController.handleNotFound + { Static.ss404Handler = Just handleNotFound , Static.ssMaxAge = maxAge } appSettings = (Static.defaultWebAppSettings "static/") diff --git a/IHP/ValidationSupport.hs b/IHP/ValidationSupport.hs index d6a4bd930..486efcd17 100644 --- a/IHP/ValidationSupport.hs +++ b/IHP/ValidationSupport.hs @@ -4,13 +4,11 @@ module IHP.ValidationSupport ( module IHP.ValidationSupport.Types -, module IHP.ValidationSupport.ValidateCanView , module IHP.ValidationSupport.ValidateField , module IHP.ValidationSupport.ValidateIsUnique ) where import IHP.ValidationSupport.Types -import IHP.ValidationSupport.ValidateCanView import IHP.ValidationSupport.ValidateIsUnique import IHP.ValidationSupport.ValidateField diff --git a/IHP/ValidationSupport/ValidateCanView.hs b/IHP/ValidationSupport/ValidateCanView.hs deleted file mode 100644 index 696155636..000000000 --- a/IHP/ValidationSupport/ValidateCanView.hs +++ /dev/null @@ -1,55 +0,0 @@ -module IHP.ValidationSupport.ValidateCanView (validateCanView) where - -import IHP.Prelude -import qualified Database.PostgreSQL.Simple as PG -import IHP.AuthSupport.Authorization -import IHP.Fetch (Fetchable, fetchOneOrNothing) -import IHP.ModelSupport (Table) -import IHP.ValidationSupport.Types - -validateCanView :: forall field user model fieldValue fetchedModel. ( - ?model :: model - , ?modelContext :: ModelContext - , PG.FromRow fetchedModel - , KnownSymbol field - , HasField field model fieldValue - , Fetchable fieldValue fetchedModel - , CanView user fetchedModel - , ValidateCanView' fieldValue fetchedModel - , HasField "meta" user MetaBag - , SetField "meta" user MetaBag - , Table fetchedModel - ) => Proxy field -> user -> IO user -validateCanView field user = do - let id = getField @field ?model - validationResult <- doValidateCanView (Proxy @fetchedModel) user id - pure (attachValidatorResult field validationResult user) - - --- | Let's say we have a model like: --- --- > Project { teamId :: Maybe TeamId } --- --- Validation for the value `Project { teamId = Nothing }` should result in `Success`. --- The usual validation logic will just do a `Project { teamId = Nothing}.teamId |> fetchOneOrNothing`. --- Simplified it's a call to `fetchOneOrNothing Nothing`, further Simplified it's `Nothing`. --- The usual validation logic will now threat that `Nothing` like a 404 model not found error (e.g. when a invalid project id is given). --- --- Therefore we have to handle this special of `Maybe TeamId` with the following type class. -class ValidateCanView' id model where - doValidateCanView :: (?modelContext :: ModelContext, CanView user model, Fetchable id model, PG.FromRow model, Table model) => Proxy model -> user -> id -> IO ValidatorResult - --- Maybe someId -instance {-# OVERLAPS #-} (ValidateCanView' id' model, Fetchable id' model, Table model) => ValidateCanView' (Maybe id') model where - -- doValidateCanView :: (?modelContext :: ModelContext, CanView user model, Fetchable id model, KnownSymbol (GetTableName model), PG.FromRow model) => Proxy model -> user -> (Maybe id) -> IO ValidatorResult - doValidateCanView model user id = maybe (pure Success) (doValidateCanView model user) id - --- Catch all -instance {-# OVERLAPPABLE #-} ValidateCanView' any model where - doValidateCanView :: (?modelContext :: ModelContext, CanView user model, Fetchable id model, PG.FromRow model, Table model) => Proxy model -> user -> id -> IO ValidatorResult - doValidateCanView model user id = do - fetchedModel <- liftIO (fetchOneOrNothing id) - canView' <- maybe (pure False) (\fetchedModel -> canView fetchedModel user) fetchedModel - pure $ if canView' - then Success - else Failure "Please pick something" diff --git a/Test/Controller/AccessDeniedSpec.hs b/Test/Controller/AccessDeniedSpec.hs new file mode 100644 index 000000000..8a847540c --- /dev/null +++ b/Test/Controller/AccessDeniedSpec.hs @@ -0,0 +1,93 @@ +{-| +Module: Test.Controller.AccessDeniedSpec +Tests for Access denied functions. +-} +{-# LANGUAGE AllowAmbiguousTypes #-} + +module Test.Controller.AccessDeniedSpec where +import qualified Prelude +import ClassyPrelude +import Test.Hspec +import IHP.Test.Mocking hiding (application) +import IHP.Prelude +import IHP.QueryBuilder +import IHP.Environment +import IHP.HaskellSupport +import IHP.RouterSupport hiding (get) +import IHP.FrameworkConfig +import IHP.Job.Types +import IHP.Controller.RequestContext hiding (request) +import IHP.ViewPrelude +import IHP.ControllerPrelude hiding (get, request) +import qualified IHP.Server as Server +import Data.Attoparsec.ByteString.Char8 (string, Parser, (), parseOnly, take, endOfInput, choice, takeTill, takeByteString) +import Network.Wai +import Network.Wai.Test +import Network.HTTP.Types +import Data.String.Conversions +import Data.Text as Text +import Unsafe.Coerce +import IHP.ApplicationContext + +import qualified Network.Wai.Session as Session +import qualified Network.Wai.Session.Map as Session + +data WebApplication = WebApplication deriving (Eq, Show, Data) + +data TestController + = TestActionAccessDeniedWhen + | TestActionAccessDeniedUnless + deriving (Eq, Show, Data) + +instance Controller TestController where + action TestActionAccessDeniedWhen = do + accessDeniedWhen True + renderPlain "Test" + action TestActionAccessDeniedUnless = do + accessDeniedUnless False + renderPlain "Test" + +instance AutoRoute TestController + +instance FrontController WebApplication where + controllers = [ parseRoute @TestController ] + + +defaultLayout :: Html -> Html +defaultLayout inner = [hsx|{inner}|] + +instance InitControllerContext WebApplication where + initContext = do + setLayout defaultLayout + +instance FrontController RootApplication where + controllers = [ mountFrontController WebApplication ] + +testGet :: ByteString -> Session SResponse +testGet url = request $ setPath defaultRequest { requestMethod = methodGet } url + + +config = do + option Development + option (AppPort 8000) + +makeApplication :: (?applicationContext :: ApplicationContext) => IO Application +makeApplication = do + store <- Session.mapStore_ + let sessionMiddleware :: Middleware = Session.withSession store "SESSION" ?applicationContext.frameworkConfig.sessionCookie ?applicationContext.session + pure (sessionMiddleware (Server.application handleNotFound)) + +assertAccessDenied :: SResponse -> IO () +assertAccessDenied response = do + response.simpleStatus `shouldBe` status403 + response.simpleBody `shouldNotBe` "Test" + +tests :: Spec +tests = beforeAll (mockContextNoDatabase WebApplication config) do + describe "Access denied" $ do + it "should return show 403 page when acessDeniedWhen is True" $ withContext do + application <- makeApplication + runSession (testGet "test/TestActionAccessDeniedWhen") application >>= assertAccessDenied + it "should return show 403 page when acessDeniedUnless is False" $ withContext do + application <- makeApplication + runSession (testGet "test/TestActionAccessDeniedUnless") application >>= assertAccessDenied \ No newline at end of file diff --git a/Test/Controller/CookieSpec.hs b/Test/Controller/CookieSpec.hs index d810c6105..ca950a556 100644 --- a/Test/Controller/CookieSpec.hs +++ b/Test/Controller/CookieSpec.hs @@ -8,10 +8,9 @@ import IHP.Prelude import Test.Hspec import IHP.Controller.RequestContext -import qualified IHP.ControllerSupport as ControllerSupport +import IHP.Controller.Response (addResponseHeadersFromContext) import IHP.Controller.Cookie import IHP.Controller.Context - import qualified Network.Wai as Wai import Web.Cookie import Network.HTTP.Types.Status @@ -29,7 +28,7 @@ tests = do } let response = Wai.responseLBS status200 [] "Hello World" - responseWithHeaders <- ControllerSupport.addResponseHeadersFromContext response + responseWithHeaders <- addResponseHeadersFromContext response Wai.responseHeaders responseWithHeaders `shouldBe` [("Set-Cookie", "exampleCookie=exampleValue")] diff --git a/Test/Controller/NotFoundSpec.hs b/Test/Controller/NotFoundSpec.hs new file mode 100644 index 000000000..2c526db25 --- /dev/null +++ b/Test/Controller/NotFoundSpec.hs @@ -0,0 +1,93 @@ +{-| +Module: Test.Controller.NotFoundSpec +Tests for Not found functions. +-} +{-# LANGUAGE AllowAmbiguousTypes #-} + +module Test.Controller.NotFoundSpec where +import qualified Prelude +import ClassyPrelude +import Test.Hspec +import IHP.Test.Mocking hiding (application) +import IHP.Prelude +import IHP.QueryBuilder +import IHP.Environment +import IHP.HaskellSupport +import IHP.RouterSupport hiding (get) +import IHP.FrameworkConfig +import IHP.Job.Types +import IHP.Controller.RequestContext hiding (request) +import IHP.ViewPrelude +import IHP.ControllerPrelude hiding (get, request) +import qualified IHP.Server as Server +import Data.Attoparsec.ByteString.Char8 (string, Parser, (), parseOnly, take, endOfInput, choice, takeTill, takeByteString) +import Network.Wai +import Network.Wai.Test +import Network.HTTP.Types +import Data.String.Conversions +import Data.Text as Text +import Unsafe.Coerce +import IHP.ApplicationContext + +import qualified Network.Wai.Session as Session +import qualified Network.Wai.Session.Map as Session + +data WebApplication = WebApplication deriving (Eq, Show, Data) + +data TestController + = TestActionNotFoundWhen + | TestActionNotFoundUnless + deriving (Eq, Show, Data) + +instance Controller TestController where + action TestActionNotFoundWhen = do + notFoundWhen True + renderPlain "Test" + action TestActionNotFoundUnless = do + notFoundUnless False + renderPlain "Test" + +instance AutoRoute TestController + +instance FrontController WebApplication where + controllers = [ parseRoute @TestController ] + + +defaultLayout :: Html -> Html +defaultLayout inner = [hsx|{inner}|] + +instance InitControllerContext WebApplication where + initContext = do + setLayout defaultLayout + +instance FrontController RootApplication where + controllers = [ mountFrontController WebApplication ] + +testGet :: ByteString -> Session SResponse +testGet url = request $ setPath defaultRequest { requestMethod = methodGet } url + + +config = do + option Development + option (AppPort 8000) + +makeApplication :: (?applicationContext :: ApplicationContext) => IO Application +makeApplication = do + store <- Session.mapStore_ + let sessionMiddleware :: Middleware = Session.withSession store "SESSION" ?applicationContext.frameworkConfig.sessionCookie ?applicationContext.session + pure (sessionMiddleware (Server.application handleNotFound)) + +assertNotFound :: SResponse -> IO () +assertNotFound response = do + response.simpleStatus `shouldBe` status404 + response.simpleBody `shouldNotBe` "Test" + +tests :: Spec +tests = beforeAll (mockContextNoDatabase WebApplication config) do + describe "Not found" $ do + it "should return show 404 page when notFoundWhen is True" $ withContext do + application <- makeApplication + runSession (testGet "test/TestActionNotFoundWhen") application >>= assertNotFound + it "should return show 404 page when notFoundUnless is False" $ withContext do + application <- makeApplication + runSession (testGet "test/TestActionNotFoundUnless") application >>= assertNotFound \ No newline at end of file diff --git a/Test/Main.hs b/Test/Main.hs index 78b6460d0..c6b52477c 100644 --- a/Test/Main.hs +++ b/Test/Main.hs @@ -36,6 +36,8 @@ import qualified Test.View.FormSpec import qualified Test.Controller.ContextSpec import qualified Test.Controller.ParamSpec import qualified Test.Controller.CookieSpec +import qualified Test.Controller.AccessDeniedSpec +import qualified Test.Controller.NotFoundSpec import qualified Test.SchemaMigrationSpec import qualified Test.ModelSupportSpec import qualified Test.SchemaCompilerSpec @@ -70,6 +72,8 @@ main = hspec do Test.View.FormSpec.tests Test.Controller.ContextSpec.tests Test.Controller.ParamSpec.tests + Test.Controller.AccessDeniedSpec.tests + Test.Controller.NotFoundSpec.tests Test.SchemaMigrationSpec.tests Test.ModelSupportSpec.tests Test.SchemaCompilerSpec.tests diff --git a/Test/RouterSupportSpec.hs b/Test/RouterSupportSpec.hs index 774a1872e..09a4c0158 100644 --- a/Test/RouterSupportSpec.hs +++ b/Test/RouterSupportSpec.hs @@ -26,7 +26,7 @@ import Data.Attoparsec.ByteString.Char8 (string, Parser, (), parseOnly, take, import Network.Wai import Network.Wai.Test import Network.HTTP.Types -import qualified IHP.ErrorController as ErrorController +import IHP.Controller.NotFound (handleNotFound) import Data.String.Conversions import Unsafe.Coerce import IHP.ApplicationContext @@ -141,7 +141,7 @@ config = do option (AppPort 8000) application :: (?applicationContext :: ApplicationContext) => Application -application = Server.application ErrorController.handleNotFound +application = Server.application handleNotFound tests :: Spec tests = beforeAll (mockContextNoDatabase WebApplication config) do diff --git a/Test/SEO/Sitemap.hs b/Test/SEO/Sitemap.hs index 035c42d59..82155b618 100644 --- a/Test/SEO/Sitemap.hs +++ b/Test/SEO/Sitemap.hs @@ -13,7 +13,7 @@ import Network.HTTP.Types import IHP.SEO.Sitemap.Types import IHP.SEO.Sitemap.Routes import IHP.SEO.Sitemap.ControllerFunctions -import qualified IHP.ErrorController as ErrorController +import IHP.Controller.NotFound (handleNotFound) data Post = Post { id :: UUID @@ -79,5 +79,5 @@ tests = beforeAll (mockContextNoDatabase WebApplication config) do describe "SEO" do describe "Sitemap" do it "should render a XML Sitemap" $ withContext do - runSession (testGet "/sitemap.xml") (Server.application ErrorController.handleNotFound) + runSession (testGet "/sitemap.xml") (Server.application handleNotFound) >>= assertSuccess "http://localhost:8000/test/ShowPost?postId=00000000-0000-0000-0000-0000000000002105-04-16hourly" diff --git a/Test/ViewSupportSpec.hs b/Test/ViewSupportSpec.hs index 4d6d7a423..cea38e686 100644 --- a/Test/ViewSupportSpec.hs +++ b/Test/ViewSupportSpec.hs @@ -102,7 +102,7 @@ makeApplication :: (?applicationContext :: ApplicationContext) => IO Application makeApplication = do store <- Session.mapStore_ let sessionMiddleware :: Middleware = Session.withSession store "SESSION" ?applicationContext.frameworkConfig.sessionCookie ?applicationContext.session - pure (sessionMiddleware (Server.application ErrorController.handleNotFound)) + pure (sessionMiddleware (Server.application handleNotFound)) tests :: Spec tests = beforeAll (mockContextNoDatabase WebApplication config) do diff --git a/ihp.cabal b/ihp.cabal index a5d5ff601..ed0befc3f 100644 --- a/ihp.cabal +++ b/ihp.cabal @@ -175,7 +175,6 @@ library hs-source-dirs: . exposed-modules: IHP.AuthSupport.Authentication - , IHP.AuthSupport.Authorization , IHP.AuthSupport.Lockable , IHP.Controller.Param , IHP.Controller.FileUpload @@ -187,12 +186,14 @@ library , IHP.Controller.Layout , IHP.Controller.BasicAuth , IHP.Controller.Cookie + , IHP.Controller.AccessDenied + , IHP.Controller.NotFound + , IHP.Controller.Response , IHP.LoginSupport.Helper.Controller , IHP.LoginSupport.Helper.View , IHP.LoginSupport.Middleware , IHP.LoginSupport.Types , IHP.ValidationSupport.Types - , IHP.ValidationSupport.ValidateCanView , IHP.ValidationSupport.ValidateField , IHP.ValidationSupport.ValidateIsUnique , IHP.View.Form