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