Refactor response handling to avoid exceptions on normal requests

.ghci

@@ -7,6 +7,7 @@
 :set -iihp-hspec
 :set -iwai-asset-path
 :set -iwai-flash-messages
+:set -iwai-early-return
 :set -threaded
 
 :set -XGHC2021

Guide/controller.markdown

@@ -398,19 +398,26 @@ action ExampleAction = do
 
 ## Action Execution
 
-When calling a function to send the response, IHP will stop executing the action. Internally this is implemented by throwing and catching a [`ResponseException`](https://ihp.digitallyinduced.com/api-docs/src/IHP.ControllerSupport.html#ResponseException). Any code after e.g. a `render SomeView { .. }` call will not be called. This also applies to all redirect helpers.
+When calling a function to send the response like `render` or `redirectTo`, the response is sent to the client and the action returns. Since these functions return `IO ResponseReceived`, any code after them would be unreachable.
 
-Here is an example of this behavior:
+Here is an example:
 
 ```haskell
 action ExampleAction = do
     redirectTo SomeOtherAction
-    putStrLn "This line here is not reachable"
+    -- Any code here would be unreachable since redirectTo returns the response
 ```
 
-The [`putStrLn`](https://ihp.digitallyinduced.com/api-docs/IHP-Prelude.html#v:putStrLn) will never be called because the [`redirectTo`](https://ihp.digitallyinduced.com/api-docs/IHP-Controller-Redirect.html#v:redirectTo) already stops execution.
+For conditional early exits (like access control), use `earlyReturn`:
 
-When you have created a [`Response`](https://hackage.haskell.org/package/wai-3.2.2.1/docs/Network-Wai.html#t:Response) manually, you can use [`respondAndExit`](https://ihp.digitallyinduced.com/api-docs/src/IHP.ControllerSupport.html#respondAndExit) to send your response and stop action execution.
+```haskell
+action ExampleAction = do
+    when (not loggedIn) do
+        earlyReturn (redirectTo LoginAction)
+
+    -- This code runs only if loggedIn is True
+    render MyView
+```
 
 ## Controller Context
 

Guide/database.markdown

@@ -822,16 +822,7 @@ incomplete data is left in the database when there's an error.
 
 The [`withTransaction`](https://ihp.digitallyinduced.com/api-docs/IHP-ModelSupport.html#v:withTransaction) function will automatically commit after it succesfully executed the passed do-block. When any exception is thrown, it will automatically rollback.
 
-Keep in mind that some IHP functions like [`redirectTo`](https://ihp.digitallyinduced.com/api-docs/IHP-Controller-Redirect.html#v:redirectTo) or [`render`](https://ihp.digitallyinduced.com/api-docs/IHP-Controller-Render.html#v:render) throw a [`ResponseException`](https://ihp.digitallyinduced.com/api-docs/IHP-ControllerSupport.html#t:ResponseException). So code like below will not work as expected:
-
-```haskell
-action CreateUserAction = do
-    withTransaction do
-        user <- newRecord @User |> createRecord
-        redirectTo NewSessionAction
-```
-
-The [`redirectTo`](https://ihp.digitallyinduced.com/api-docs/IHP-Controller-Redirect.html#v:redirectTo) throws a [`ResponseException`](https://ihp.digitallyinduced.com/api-docs/IHP-ControllerSupport.html#t:ResponseException) and will cause a rollback. This code should be structured like this:
+It's good practice to keep your transaction blocks focused on database operations only:
 
 ```haskell
 action CreateUserAction = do

NixSupport/overlay.nix

@@ -24,6 +24,7 @@ final: prev: {
             ihp-job-dashboard = localPackage"ihp-job-dashboard";
             wai-asset-path = localPackage "wai-asset-path";
             wai-flash-messages = localPackage "wai-flash-messages";
+            wai-early-return = localPackage "wai-early-return";
             ihp-imagemagick = localPackage "ihp-imagemagick";
             ihp-hspec = localPackage "ihp-hspec";
             ihp-welcome = localPackage "ihp-welcome";

devenv-module.nix

@@ -151,6 +151,7 @@ that is defined in flake-module.nix
             ihp-job-dashboard = pkgs.ghc.ihp-job-dashboard;
             wai-asset-path = pkgs.ghc.wai-asset-path;
             wai-flash-messages = pkgs.ghc.wai-flash-messages;
+            wai-early-return = pkgs.ghc.wai-early-return;
             ihp-imagemagick = pkgs.ghc.ihp-imagemagick;
             ihp-hspec = pkgs.ghc.ihp-hspec;
             ihp-welcome = pkgs.ghc.ihp-welcome;

ihp-datasync/IHP/DataSync/REST/Controller.hs

@@ -2,6 +2,7 @@
 module IHP.DataSync.REST.Controller where
 
 import IHP.ControllerPrelude hiding (OrderByClause)
+import Network.Wai (ResponseReceived)
 import IHP.DataSync.REST.Types
 import Data.Aeson
 import qualified Database.PostgreSQL.Simple.ToField as PG
@@ -192,7 +193,7 @@ instance ToJSON PG.SqlError where
 instance ToJSON EnhancedSqlError where
     toJSON EnhancedSqlError { sqlError } = toJSON sqlError
 
-renderErrorJson :: (?context :: ControllerContext) => Data.Aeson.ToJSON json => json -> IO ()
+renderErrorJson :: (?context :: ControllerContext) => Data.Aeson.ToJSON json => json -> IO ResponseReceived
 renderErrorJson json = renderJsonWithStatusCode status400 json
 {-# INLINABLE renderErrorJson #-}
 

ihp-ide/IHP/IDE/CodeGen/Controller.hs

@@ -36,11 +36,13 @@ instance Controller CodeGenController where
         let pagination = paramOrDefault False "pagination"
         controllerAlreadyExists <- doesControllerExist controllerName applicationName
         applications <- findApplications
-        when controllerAlreadyExists do
-            setErrorMessage "Controller with this name does already exist."
-            redirectTo NewControllerAction
-        plan <- ControllerGenerator.buildPlan controllerName applicationName pagination
-        render NewControllerView { .. }
+        if controllerAlreadyExists
+            then do
+                setErrorMessage "Controller with this name does already exist."
+                redirectTo NewControllerAction
+            else do
+                plan <- ControllerGenerator.buildPlan controllerName applicationName pagination
+                render NewControllerView { .. }
         where
             doesControllerExist controllerName applicationName = doesFileExist $ cs applicationName <> "/Controller/" <> cs controllerName <> ".hs"
 
@@ -56,11 +58,13 @@ instance Controller CodeGenController where
     action NewScriptAction = do
         let scriptName = paramOrDefault "" "name"
         scriptAlreadyExists <- doesFileExist $ "Application/Script/" <> cs scriptName <> ".hs"
-        when scriptAlreadyExists do
-            setErrorMessage "Script with this name already exists."
-            redirectTo NewScriptAction
-        let plan = ScriptGenerator.buildPlan scriptName
-        render NewScriptView { .. }
+        if scriptAlreadyExists
+            then do
+                setErrorMessage "Script with this name already exists."
+                redirectTo NewScriptAction
+            else do
+                let plan = ScriptGenerator.buildPlan scriptName
+                render NewScriptView { .. }
 
     action CreateScriptAction = do
         let scriptName = paramOrDefault "" "name"
@@ -74,13 +78,15 @@ instance Controller CodeGenController where
         let applicationName = paramOrDefault "Web" "applicationName"
         let controllerName = paramOrDefault "" "controllerName"
         viewAlreadyExists <- doesFileExist $ (cs applicationName) <> "/View/" <> (cs controllerName) <> "/" <> (cs viewName) <>".hs"
-        when viewAlreadyExists do
-            setErrorMessage "View with this name already exists."
-            redirectTo NewViewAction
-        controllers <- findControllers applicationName
-        applications <- findApplications
-        plan <- ViewGenerator.buildPlan viewName applicationName controllerName
-        render NewViewView { .. }
+        if viewAlreadyExists
+            then do
+                setErrorMessage "View with this name already exists."
+                redirectTo NewViewAction
+            else do
+                controllers <- findControllers applicationName
+                applications <- findApplications
+                plan <- ViewGenerator.buildPlan viewName applicationName controllerName
+                render NewViewView { .. }
 
     action CreateViewAction = do
         let viewName = paramOrDefault "" "name"
@@ -96,13 +102,15 @@ instance Controller CodeGenController where
         let applicationName = paramOrDefault "Web" "applicationName"
         let controllerName = paramOrDefault "" "controllerName"
         mailAlreadyExists <- doesFileExist $ (cs applicationName) <> "/Mail/" <> (cs controllerName) <> "/" <> (cs mailName) <>".hs"
-        when mailAlreadyExists do
-            setErrorMessage "Mail with this name already exists."
-            redirectTo NewMailAction
-        controllers <- findControllers applicationName
-        applications <- findApplications
-        plan <- MailGenerator.buildPlan mailName applicationName controllerName
-        render NewMailView { .. }
+        if mailAlreadyExists
+            then do
+                setErrorMessage "Mail with this name already exists."
+                redirectTo NewMailAction
+            else do
+                controllers <- findControllers applicationName
+                applications <- findApplications
+                plan <- MailGenerator.buildPlan mailName applicationName controllerName
+                render NewMailView { .. }
 
     action CreateMailAction = do
         let mailName = paramOrDefault "" "name"

ihp-ide/IHP/IDE/Data/Controller.hs

@@ -47,18 +47,18 @@ instance Controller DataController where
     action QueryAction = do
         connection <- connectToAppDb
         let queryText = param @Text "query"
-        when (isEmpty queryText) do
-            redirectTo NewQueryAction
-
-        let query = fromString $ cs queryText
-
-        queryResult :: Maybe (Either PG.SqlError SqlConsoleResult) <- Just <$> if isQuery queryText then
-                (Right . SelectQueryResult <$> PG.query_ connection query) `catch` (pure . Left)
-            else
-                (Right . InsertOrUpdateResult <$> PG.execute_ connection query) `catch` (pure . Left)
-
-        PG.close connection
-        render ShowQueryView { .. }
+        if isEmpty queryText
+            then redirectTo NewQueryAction
+            else do
+                let query = fromString $ cs queryText
+
+                queryResult :: Maybe (Either PG.SqlError SqlConsoleResult) <- Just <$> if isQuery queryText then
+                        (Right . SelectQueryResult <$> PG.query_ connection query) `catch` (pure . Left)
+                    else
+                        (Right . InsertOrUpdateResult <$> PG.execute_ connection query) `catch` (pure . Left)
+
+                PG.close connection
+                render ShowQueryView { .. }
 
     action DeleteEntryAction { primaryKey, tableName } = do
         connection <- connectToAppDb

ihp-ide/IHP/IDE/SchemaDesigner/Controller/Migrations.hs

@@ -54,6 +54,7 @@ instance Controller MigrationsController where
             then do
                 setSuccessMessage ("Migration generated: " <> path)
                 openEditor path 0 0
+                redirectTo MigrationsAction
             else do
                 result <- Exception.try (migrateAppDB revision)
                 case result of
@@ -68,8 +69,6 @@ instance Controller MigrationsController where
                         clearDatabaseNeedsMigration
                         redirectTo MigrationsAction
 
-        redirectTo MigrationsAction
-
     action EditMigrationAction { migrationId } = do
         migration <- findMigrationByRevision migrationId
         sqlStatements <- readSqlStatements migration

ihp-job-dashboard/IHP/Job/Dashboard.hs

@@ -34,6 +34,7 @@ module IHP.Job.Dashboard (
 import IHP.Prelude
 import IHP.ModelSupport
 import IHP.ControllerPrelude
+import Network.Wai (ResponseReceived)
 import Unsafe.Coerce
 import IHP.Job.Queue ()
 import IHP.Pagination.Types
@@ -116,27 +117,27 @@ class JobsDashboard (jobs :: [Type]) where
     includedJobTables :: [Text]
 
     -- | Renders the index page, which is the view returned from 'makeDashboard'.
-    indexPage :: (?context :: ControllerContext, ?modelContext :: ModelContext) => IO ()
+    indexPage :: (?context :: ControllerContext, ?modelContext :: ModelContext) => IO ResponseReceived
 
-    listJob :: (?context :: ControllerContext, ?modelContext :: ModelContext) => Text -> IO ()
-    listJob' :: (?context :: ControllerContext, ?modelContext :: ModelContext) => Bool -> IO ()
+    listJob :: (?context :: ControllerContext, ?modelContext :: ModelContext) => Text -> IO ResponseReceived
+    listJob' :: (?context :: ControllerContext, ?modelContext :: ModelContext) => Bool -> IO ResponseReceived
 
     -- | Renders the detail view page. Rescurses on the type list to find a type with the
     -- same table name as the "tableName" query parameter.
-    viewJob :: (?context :: ControllerContext, ?modelContext :: ModelContext) => Text -> UUID -> IO ()
-    viewJob' :: (?context :: ControllerContext, ?modelContext :: ModelContext) => Bool -> IO ()
+    viewJob :: (?context :: ControllerContext, ?modelContext :: ModelContext) => Text -> UUID -> IO ResponseReceived
+    viewJob' :: (?context :: ControllerContext, ?modelContext :: ModelContext) => Bool -> IO ResponseReceived
 
     -- | If performed in a POST request, creates a new job depending on the "tableName" query parameter.
     -- If performed in a GET request, renders the new job from depending on said parameter.
-    newJob :: (?context :: ControllerContext, ?modelContext :: ModelContext) => Text -> IO ()
-    newJob' :: (?context :: ControllerContext, ?modelContext :: ModelContext) => Bool -> IO ()
+    newJob :: (?context :: ControllerContext, ?modelContext :: ModelContext) => Text -> IO ResponseReceived
+    newJob' :: (?context :: ControllerContext, ?modelContext :: ModelContext) => Bool -> IO ResponseReceived
 
     -- | Deletes a job from the database.
-    deleteJob :: (?context :: ControllerContext, ?modelContext :: ModelContext) => Text -> UUID -> IO ()
-    deleteJob' :: (?context :: ControllerContext, ?modelContext :: ModelContext) => Bool -> IO ()
+    deleteJob :: (?context :: ControllerContext, ?modelContext :: ModelContext) => Text -> UUID -> IO ResponseReceived
+    deleteJob' :: (?context :: ControllerContext, ?modelContext :: ModelContext) => Bool -> IO ResponseReceived
 
-    retryJob :: (?context :: ControllerContext, ?modelContext :: ModelContext) => Text -> UUID -> IO ()
-    retryJob' :: (?context :: ControllerContext, ?modelContext :: ModelContext) => IO ()
+    retryJob :: (?context :: ControllerContext, ?modelContext :: ModelContext) => Text -> UUID -> IO ResponseReceived
+    retryJob' :: (?context :: ControllerContext, ?modelContext :: ModelContext) => IO ResponseReceived
 
 -- If no types are passed, try to get all tables dynamically and render them as BaseJobs
 instance JobsDashboard '[] where
@@ -250,7 +251,7 @@ instance {-# OVERLAPPABLE #-} (DisplayableJob job, JobsDashboard rest) => JobsDa
 
         when isFirstTime $ do
             notIncluded <- getNotIncludedTableNames (includedJobTables @(job:rest))
-            when (table `elem` notIncluded) (listJob' @'[] False)
+            when (table `elem` notIncluded) (earlyReturn $ listJob' @'[] False)
 
         if tableName @job == table
             then listJob @(job:rest) table
@@ -273,7 +274,7 @@ instance {-# OVERLAPPABLE #-} (DisplayableJob job, JobsDashboard rest) => JobsDa
 
         when isFirstTime $ do
             notIncluded <- getNotIncludedTableNames (includedJobTables @(job:rest))
-            when (table `elem` notIncluded) (viewJob' @'[] False)
+            when (table `elem` notIncluded) (earlyReturn $ viewJob' @'[] False)
 
         if tableName @job == table
             then viewJob @(job:rest) table (param "id")
@@ -301,7 +302,7 @@ instance {-# OVERLAPPABLE #-} (DisplayableJob job, JobsDashboard rest) => JobsDa
 
         when isFirstTime $ do
             notIncluded <- getNotIncludedTableNames (includedJobTables @(job:rest))
-            when (table `elem` notIncluded) (newJob' @'[] False)
+            when (table `elem` notIncluded) (earlyReturn $ newJob' @'[] False)
 
         if tableName @job == table
             then newJob @(job:rest) table
@@ -322,7 +323,7 @@ instance {-# OVERLAPPABLE #-} (DisplayableJob job, JobsDashboard rest) => JobsDa
 
         when isFirstTime $ do
             notIncluded <- getNotIncludedTableNames (includedJobTables @(job:rest))
-            when (table `elem` notIncluded) (deleteJob' @'[] False)
+            when (table `elem` notIncluded) (earlyReturn $ deleteJob' @'[] False)
 
         if tableName @job == table
             then deleteJob @(job:rest) table (param "id")

ihp-sitemap/IHP/SEO/Sitemap/ControllerFunctions.hs

@@ -7,7 +7,7 @@ import qualified Text.Blaze as Markup
 import qualified Text.Blaze.Internal as Markup
 import qualified Text.Blaze.Renderer.Utf8 as Markup
 
-renderXmlSitemap :: (?context::ControllerContext) => Sitemap -> IO ()
+renderXmlSitemap :: (?context::ControllerContext) => Sitemap -> IO ResponseReceived
 renderXmlSitemap Sitemap { links } = do
     let sitemap = Markup.toMarkup [xmlDocument, sitemapLinks]
     renderXml $ Markup.renderMarkup sitemap