From 6fbd6343b626080f3e1b37cb3937dfeaecd4d933 Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Mon, 13 Apr 2026 11:06:53 +0200 Subject: [PATCH 01/27] Remove ControllerContext TMap, delete ihp-context package ControllerContext is now a thin record wrapping the WAI Request: all per-request state lives in request.vault. The TMap-based API (putContext, fromContext, freeze, unfreeze, FrozenControllerContext) is no longer used by the framework after PRs #2632 and #2259, so remove it along with the ihp-context package. Other changes that fall out of this: - AutoRefresh and Render no longer freeze/unfreeze the context, the captured request closure is the snapshot. - Drop the legacy initAuthentication wrapper (use authMiddleware). - Delete Test.Controller.ContextSpec. - Update Guide/UPGRADE docs to use vault-key patterns. Co-Authored-By: Claude Opus 4.6 (1M context) --- Guide/architecture.markdown | 5 +- Guide/authentication.markdown | 8 +- Guide/authorization.markdown | 3 +- Guide/passkeys.markdown | 5 +- Guide/recipes.markdown | 6 +- Guide/seo.markdown | 39 +++- Guide/session.markdown | 2 +- Guide/view.markdown | 60 +++---- NixSupport/overlay.nix | 1 - UPGRADE.md | 28 ++- cabal.project | 1 - devenv-module.nix | 4 +- ihp-context/IHP/ControllerContext.hs | 170 ------------------ ihp-context/LICENSE | 21 --- ihp-context/default.nix | 10 -- ihp-context/ihp-context.cabal | 44 ----- .../Test/DataSync/DataSyncIntegrationSpec.hs | 6 +- ihp-modal/default.nix | 8 +- ihp-modal/ihp-modal.cabal | 3 +- ihp-pagehead/default.nix | 8 +- ihp-pagehead/ihp-pagehead.cabal | 3 +- ihp/IHP/AutoRefresh.hs | 15 +- ihp/IHP/Controller/Context.hs | 56 ++---- ihp/IHP/Controller/Render.hs | 8 +- ihp/IHP/LoginSupport/Middleware.hs | 27 +-- ihp/IHP/RouterSupport.hs | 7 +- ihp/Test/Test/Controller/ContextSpec.hs | 112 ------------ ihp/Test/Test/Controller/ParamSpec.hs | 6 +- ihp/Test/Test/Main.hs | 2 - .../Pagination/ControllerFunctionsSpec.hs | 3 +- ihp/Test/Test/RouterSupportSpec.hs | 2 +- ihp/Test/Test/View/CSSFrameworkSpec.hs | 3 +- ihp/Test/Test/View/FormSpec.hs | 3 +- ihp/default.nix | 87 +++++---- ihp/ihp.cabal | 2 - 35 files changed, 180 insertions(+), 588 deletions(-) delete mode 100644 ihp-context/IHP/ControllerContext.hs delete mode 100644 ihp-context/LICENSE delete mode 100644 ihp-context/default.nix delete mode 100644 ihp-context/ihp-context.cabal delete mode 100644 ihp/Test/Test/Controller/ContextSpec.hs diff --git a/Guide/architecture.markdown b/Guide/architecture.markdown index 5038ba144..ade680502 100644 --- a/Guide/architecture.markdown +++ b/Guide/architecture.markdown @@ -307,15 +307,16 @@ The router maps URLs like `/Posts` to `PostsAction`, `/ShowPost?postId=...` to ` ### Step 7: initContext Runs -Before your action code runs, IHP calls `initContext` from your application's `InitControllerContext` instance. This is where you set up shared controller state, such as loading the currently logged-in user: +Before your action code runs, IHP calls `initContext` from your application's `InitControllerContext` instance. This is where you set up shared controller state, such as the default layout: ```haskell instance InitControllerContext WebApplication where initContext = do setLayout defaultLayout - initAuthentication @User ``` +Authentication runs earlier as a WAI middleware (`AuthMiddleware (authMiddleware @User)` in `Config.hs`) so the current user is already in the request vault by the time `initContext` runs. + If `initContext` throws an exception (for example, if authentication redirects to a login page), the action is never called. ### Step 8: beforeAction Runs diff --git a/Guide/authentication.markdown b/Guide/authentication.markdown index 0efc91b1d..fddbbe581 100644 --- a/Guide/authentication.markdown +++ b/Guide/authentication.markdown @@ -887,7 +887,7 @@ config = do ### How Login and Logout Work -When a user logs in, IHP stores the user's ID in the session under the key `login.User` (or `login.Admin` for admin authentication). The key is constructed from the model name, not the table name. The `initAuthentication @User` call in your `FrontController.hs` reads this session value on each request and fetches the corresponding user record from the database. +When a user logs in, IHP stores the user's ID in the session under the key `login.User` (or `login.Admin` for admin authentication). The key is constructed from the model name, not the table name. The `authMiddleware @User` middleware (configured in `Config.hs`) reads this session value on each request and fetches the corresponding user record from the database. When a user logs out, IHP sets the session value for `login.User` to an empty string. The session cookie itself remains, but the user ID is cleared. @@ -980,10 +980,12 @@ Here is a summary of every change needed to add authentication. Use this as a re - Implement the login form view 6. In `Web/FrontController.hs`: - - Add `import IHP.LoginSupport.Middleware` - Add `import Web.Controller.Sessions` - Mount the controller: `parseRoute @SessionsController` - - Add `initAuthentication @User` to `initContext` + +7. In `Config/Config.hs`: + - Add `import IHP.LoginSupport.Middleware` + - Add `option $ AuthMiddleware (authMiddleware @User)` 7. Add `ensureIsUser` to `beforeAction` in any controller that requires login. diff --git a/Guide/authorization.markdown b/Guide/authorization.markdown index 75e2cb06b..c454a7f39 100644 --- a/Guide/authorization.markdown +++ b/Guide/authorization.markdown @@ -520,13 +520,12 @@ This approach gives you full control over what the user sees and where they are For an additional layer of protection, IHP supports PostgreSQL Row-Level Security (RLS). With RLS, the database itself enforces that users can only access rows they are authorized to see, regardless of what your application code does. -See the [IHP DataSync documentation](https://ihp.digitallyinduced.com/Guide/realtime-spas.html) for details on how to set up RLS policies. In your `FrontController.hs`, call `enableRowLevelSecurityIfLoggedIn` after `initAuthentication`: +See the [IHP DataSync documentation](https://ihp.digitallyinduced.com/Guide/realtime-spas.html) for details on how to set up RLS policies. With `AuthMiddleware (authMiddleware @User)` enabled in `Config.hs`, call `enableRowLevelSecurityIfLoggedIn` from your `FrontController.hs`: ```haskell instance InitControllerContext WebApplication where initContext = do setLayout defaultLayout - initAuthentication @User enableRowLevelSecurityIfLoggedIn ``` diff --git a/Guide/passkeys.markdown b/Guide/passkeys.markdown index 4dc6e0ab9..e7df3b1d2 100644 --- a/Guide/passkeys.markdown +++ b/Guide/passkeys.markdown @@ -340,10 +340,11 @@ instance FrontController WebApplication where ] instance InitControllerContext WebApplication where - initContext = do - initAuthentication @User + initContext = pure () ``` +In `Config/Config.hs` add `option $ AuthMiddleware (authMiddleware @User)` so the current user is loaded into the request vault on every request. + ### Sessions Controller Create `Web/Controller/Sessions.hs` for logout: diff --git a/Guide/recipes.markdown b/Guide/recipes.markdown index bfd6b4fd4..0fc352f6a 100644 --- a/Guide/recipes.markdown +++ b/Guide/recipes.markdown @@ -233,9 +233,7 @@ The `DeleteSessionAction` expects a `HTTP DELETE` request, which is set by JavaS ## Making a dynamic Login/Logout button -Depending on the `Maybe User` type in the [ControllerContext](https://ihp.digitallyinduced.com/api-docs/IHP-Controller-Context.html), by using [`fromFrozenContext`](https://ihp.digitallyinduced.com/api-docs/IHP-Controller-Context.html#v:fromFrozenContext) we can tell if no user is logged in when the `Maybe User` is `Nothing`, and confirm someone is logged in if the `Maybe User` is a `Just user`. Here is an example of a navbar, which has a dynamic Login/Logout button. You can define this in your View/Layout to reuse this in your Views. - -> The `@` syntax from [`fromFrozenContext @(Maybe User)`](https://ihp.digitallyinduced.com/api-docs/IHP-Controller-Context.html#v:fromFrozenContext) is just syntax sugar for `let maybeUser :: Maybe User = fromFrozenContext` +Use [`currentUserOrNothing`](https://ihp.digitallyinduced.com/api-docs/IHP-LoginSupport-Helper-View.html#v:currentUserOrNothing) to check whether someone is logged in. It returns `Just user` when a user is authenticated and `Nothing` otherwise. Here is an example of a navbar with a dynamic Login/Logout button that you can place in your View/Layout to reuse across your views. ```haskell navbar :: Html @@ -259,7 +257,7 @@ navbar = [hsx| where loginLogoutButton :: Html loginLogoutButton = - case fromFrozenContext @(Maybe User) of + case currentUserOrNothing of Just user -> [hsx|Logout|] Nothing -> [hsx|Login|] ``` diff --git a/Guide/seo.markdown b/Guide/seo.markdown index 491b291ba..50998a6ac 100644 --- a/Guide/seo.markdown +++ b/Guide/seo.markdown @@ -206,7 +206,7 @@ defaultLayout inner = [hsx| |] ``` -If you want per-page Twitter tags, you can use the same `putContext`/`fromFrozenContext` pattern described in the [Views documentation](view.html) for layout variables. +If you want per-page Twitter tags, you can use the same vault-key pattern described in the [Views documentation](view.html) for layout variables. ## Canonical URLs @@ -214,15 +214,36 @@ A canonical URL tells search engines which version of a page is the "official" o ### Adding a Canonical Tag to the Layout -Since IHP does not have a built-in `setCanonical` helper, you can use the `putContext`/`fromFrozenContext` pattern to pass a canonical URL from your view to the layout. +Since IHP does not have a built-in `setCanonical` helper, you can store the canonical URL in the WAI request vault and read it back in the layout. -First, create a newtype to store the canonical URL. You can add this to `Web/View/Layout.hs` or a shared module: +First, declare a vault key and a tiny middleware to set it: ```haskell +-- Web/View/Layout.hs (or a shared module) +import qualified Data.Vault.Lazy as Vault +import Network.Wai (Request, vault) +import System.IO.Unsafe (unsafePerformIO) + newtype CanonicalUrl = CanonicalUrl Text + +canonicalUrlVaultKey :: Vault.Key (IORef (Maybe CanonicalUrl)) +canonicalUrlVaultKey = unsafePerformIO Vault.newKey +{-# NOINLINE canonicalUrlVaultKey #-} + +setCanonical :: (?request :: Request) => Text -> IO () +setCanonical url = case Vault.lookup canonicalUrlVaultKey (vault ?request) of + Just ref -> writeIORef ref (Just (CanonicalUrl url)) + Nothing -> pure () + +currentCanonical :: (?request :: Request) => Maybe CanonicalUrl +currentCanonical = case Vault.lookup canonicalUrlVaultKey (vault ?request) of + Just ref -> unsafePerformIO (readIORef ref) + Nothing -> Nothing ``` -In your layout, read the canonical URL from the context and render it if present: +Add `insertNewIORefVaultMiddleware canonicalUrlVaultKey Nothing` to your `Config/Config.hs` middleware stack so the IORef is created on every request. + +In your layout, read the canonical URL from the vault and render it if present: ```haskell defaultLayout :: Html -> Html @@ -240,21 +261,21 @@ defaultLayout inner = [hsx| |] -canonicalTag :: (?context :: ControllerContext) => Html -canonicalTag = case maybeFromFrozenContext @CanonicalUrl of +canonicalTag :: (?request :: Request) => Html +canonicalTag = case currentCanonical of Just (CanonicalUrl url) -> [hsx||] Nothing -> mempty ``` ### Setting a Canonical URL from a Controller -Set the canonical URL by calling `putContext` in your action: +Call `setCanonical` in your action: ```haskell instance Controller PostsController where action ShowPostAction { postId } = do post <- fetch postId - putContext (CanonicalUrl (urlTo ShowPostAction { postId = post.id })) + setCanonical (urlTo ShowPostAction { postId = post.id }) render ShowView { .. } ``` @@ -604,7 +625,7 @@ instance View ShowView where Just url -> setOGImage url Nothing -> pure () - putContext (CanonicalUrl (urlTo ShowPostAction { postId = post.id })) + setCanonical (urlTo ShowPostAction { postId = post.id }) html ShowView { post } = [hsx|

{post.title}

diff --git a/Guide/session.markdown b/Guide/session.markdown index f89ebedb8..d616997ff 100644 --- a/Guide/session.markdown +++ b/Guide/session.markdown @@ -121,7 +121,7 @@ The rendered HTML looks like this:
{errorMessage}
``` -To display the Flash Messages in a custom way, you can always access them using `let flashMessages :: [FlashMessage] = fromFrozenContext` in your views. This returns a list of [`FlashMessage`](https://ihp.digitallyinduced.com/api-docs/IHP-FlashMessages-Types.html#t:FlashMessage). You can also take a look at the [`renderFlashMessages`](https://ihp.digitallyinduced.com/api-docs/IHP-FlashMessages-ViewFunctions.html#v:renderFlashMessages) implementation and copy the code into your view, and then make customizations. +To display the Flash Messages in a custom way, call `requestFlashMessages ?request` in your view. This returns a list of [`FlashMessage`](https://ihp.digitallyinduced.com/api-docs/IHP-FlashMessages-Types.html#t:FlashMessage). You can also take a look at the [`renderFlashMessages`](https://ihp.digitallyinduced.com/api-docs/IHP-FlashMessages-ViewFunctions.html#v:renderFlashMessages) implementation and copy the code into your view, and then make customizations. ## Session Cookie diff --git a/Guide/view.markdown b/Guide/view.markdown index 21b56059a..48bc1daf1 100644 --- a/Guide/view.markdown +++ b/Guide/view.markdown @@ -115,36 +115,41 @@ Here's some examples: In all of these cases you don't want to deal with passing the information to the layout inside every action of your application. -The general idea is that we store the needed information inside the controller context. The controller context is an implicit parameter that is passed around via the `?context` variable during the request response lifecycle. Think of it as a key-value map which you can write to before rendering, and read from during the view rendering. +The general idea is to store the needed information in the WAI request vault. A WAI middleware writes the value into the vault before your action runs; the layout reads it back through a small accessor function. Let's deal with the first case: Our business application wants to display the user's company name as part of the layout on every page. -Open `Web/FrontController.hs` and customize it like this: +First, define a vault key and a middleware that fills it in. Put this somewhere you can import from both the layout and `Config.hs`: ```haskell --- Web/FrontController.hs +-- Application/CompanyContext.hs -instance InitControllerContext WebApplication where - initContext = do - -- ... +import qualified Data.Vault.Lazy as Vault +import Network.Wai (Middleware, Request, vault) +import System.IO.Unsafe (unsafePerformIO) +import IHP.RequestVault.Helper (insertVaultMiddleware, lookupRequestVault) - initCompanyContext -- <---- ADD THIS +companyVaultKey :: Vault.Key (Maybe Company) +companyVaultKey = unsafePerformIO Vault.newKey +{-# NOINLINE companyVaultKey #-} -initCompanyContext :: (?context :: ControllerContext, ?modelContext :: ModelContext) => IO () -initCompanyContext = - case currentUserOrNothing of - Just currentUser -> do - company <- fetch currentUser.companyId +-- | Fetches the current user's company and stores it in the vault. +companyMiddleware :: ModelContext -> Middleware +companyMiddleware modelContext app req respond = do + let ?modelContext = modelContext + let ?request = req + company <- case currentUserOrNothing of + Just user -> Just <$> fetch user.companyId + Nothing -> pure Nothing + let req' = req { vault = Vault.insert companyVaultKey company (vault req) } + app req' respond - -- Here the magic happens: We put the company of the user into the context - putContext company - - Nothing -> pure () +-- | Read the current company from any view or controller. +currentCompany :: (?request :: Request) => Maybe Company +currentCompany = fromMaybe Nothing (Vault.lookup companyVaultKey (vault ?request)) ``` -The [`initContext`](https://ihp.digitallyinduced.com/api-docs/IHP-ControllerSupport.html#v:initContext) is called on every request, just before the action is executed. The `initCompanyContext` fetches the current user's company and then calls [`putContext company`](https://ihp.digitallyinduced.com/api-docs/IHP-Controller-Context.html#v:putContext) to store it inside the controller context. - -Next we'll read the company from the `Layout.hs`: +Then wire `companyMiddleware` into your `Config/Config.hs` after `AuthMiddleware`, and read it from the layout: ```haskell -- Web/View/Layout.hs @@ -153,27 +158,18 @@ defaultLayout :: Html -> Html defaultLayout inner = [hsx| {inner} - {when isLoggedIn renderCompany} + {forEach currentCompany renderCompany} |] - where - isLoggedIn = isJust currentUserOrNothing -renderCompany :: Html -renderCompany = [hsx| +renderCompany :: Company -> Html +renderCompany company = [hsx|
{company.name}
|] - -company :: (?context :: ControllerContext) => Company -company = fromFrozenContext ``` -Here the company is read by using the [`fromFrozenContext`](https://ihp.digitallyinduced.com/api-docs/IHP-Controller-Context.html#v:fromFrozenContext) function. - -You might wonder: How does [`fromFrozenContext`](https://ihp.digitallyinduced.com/api-docs/IHP-Controller-Context.html#v:fromFrozenContext) know that I want the company? The context is a key-value map, where the key's are the type of the object. Using the `company :: Company` type annotation the [`fromFrozenContext`](https://ihp.digitallyinduced.com/api-docs/IHP-Controller-Context.html#v:fromFrozenContext) knows we want to read the value with the key `Company`. - -Now the `company` variable can be used to read the current user's company across the layout and also in all views (you need to add `company` to the export list of the Layout module for that). If the `company` value is used somewhere during rendering while the user is not logged in, it will raise a runtime error. +Why a vault key per piece of state? The request vault is the single source of truth for per-request data. A dedicated `Vault.Key Company` makes the dependency explicit, type-safe, and trivial to look up from any view or controller without going through the controller context. ## Common View Tasks diff --git a/NixSupport/overlay.nix b/NixSupport/overlay.nix index 695c458f4..0418068c9 100644 --- a/NixSupport/overlay.nix +++ b/NixSupport/overlay.nix @@ -53,7 +53,6 @@ let in { ihp = localPackage "ihp"; ihp-with-docs = localPackageWithHaddock "ihp"; - ihp-context = localPackage "ihp-context"; ihp-pagehead = localPackage "ihp-pagehead"; ihp-log = localPackage "ihp-log"; ihp-pglistener = localPackage "ihp-pglistener"; diff --git a/UPGRADE.md b/UPGRADE.md index 1bf60d53d..c2d909b71 100644 --- a/UPGRADE.md +++ b/UPGRADE.md @@ -38,7 +38,7 @@ The `renderJson` function is unchanged and can still be used directly in control ## Authentication moved to WAI middleware -The `initAuthentication` function has been deprecated in favor of a WAI middleware approach. Authentication now runs as middleware before your controllers, storing the current user in the WAI request vault. +The `initAuthentication` function has been removed in favor of a WAI middleware approach. Authentication now runs as middleware before your controllers, storing the current user in the WAI request vault. **Migration steps:** @@ -68,7 +68,31 @@ The `initAuthentication` function has been deprecated in favor of a WAI middlewa option $ AuthMiddleware (authMiddleware @User . adminAuthMiddleware @Admin) ``` -**Deprecated functions:** `initAuthentication` still works but is deprecated. `currentRoleOrNothing`, `currentRole`, `currentRoleId`, `ensureIsRole` have been removed. Use the type-specific variants instead: `currentUserOrNothing`/`currentAdminOrNothing`, `currentUser`/`currentAdmin`, `currentUserId`/`currentAdminId`, `ensureIsUser`/`ensureIsAdmin`. +**Removed functions:** `initAuthentication`, `currentRoleOrNothing`, `currentRole`, `currentRoleId`, `ensureIsRole`. Use the type-specific variants instead: `currentUserOrNothing`/`currentAdminOrNothing`, `currentUser`/`currentAdmin`, `currentUserId`/`currentAdminId`, `ensureIsUser`/`ensureIsAdmin`. + +## ControllerContext TMap API removed + +The typed-map storage on `ControllerContext` has been removed. The functions `putContext`, `fromContext`, `maybeFromContext`, `fromFrozenContext`, `maybeFromFrozenContext`, `freeze`, and `unfreeze` no longer exist, and the `FrozenControllerContext` constructor is gone. The `ihp-context` package has also been deleted — drop it from your `cabal.project`/`build-depends` if you referenced it directly. + +`ControllerContext` is now a thin wrapper around the WAI `Request`. All per-request state (auth user, framework config, logger, page head, modal state, ...) lives in the request vault. To store your own per-request value, define a `Vault.Key` and a small middleware: + +```haskell +import qualified Data.Vault.Lazy as Vault +import IHP.RequestVault.Helper (insertVaultMiddleware, lookupRequestVault) +import System.IO.Unsafe (unsafePerformIO) + +myValueVaultKey :: Vault.Key MyValue +myValueVaultKey = unsafePerformIO Vault.newKey +{-# NOINLINE myValueVaultKey #-} + +-- In Config.hs: +option $ CustomMiddleware (insertVaultMiddleware myValueVaultKey someValue) + +-- In a controller or view: +let value = lookupRequestVault myValueVaultKey ?request +``` + +If you need mutable per-request state, store an `IORef` in the vault (use `insertNewIORefVaultMiddleware`). See how `IHP.LoginSupport.Types.currentUserVaultKey`, `IHP.RequestVault.loggerVaultKey`, and `IHP.PageHead.Types.pageHeadVaultKey` are defined for working examples. ## Join Support Removed from QueryBuilder diff --git a/cabal.project b/cabal.project index 79efa7f5e..054008924 100644 --- a/cabal.project +++ b/cabal.project @@ -1,6 +1,5 @@ packages: ihp/ - ihp-context/ ihp-hsx/ ihp-log/ ihp-modal/ diff --git a/devenv-module.nix b/devenv-module.nix index 6b94de658..9491ddcdf 100644 --- a/devenv-module.nix +++ b/devenv-module.nix @@ -147,7 +147,7 @@ that is defined in flake-module.nix ghc912 = pkgs.ghc912; ihpPackageNames = [ "ihp-ide" "ihp-hsx" "ihp-schema-compiler" - "ihp-postgres-parser" "ihp-context" "ihp-pagehead" + "ihp-postgres-parser" "ihp-pagehead" "ihp-log" "ihp-modal" "ihp-mail" "ihp-migrate" "ihp-openai" "ihp-ssc" "ihp-graphql" "ihp-datasync-typescript" "ihp-sitemap" @@ -174,7 +174,7 @@ that is defined in flake-module.nix ghc914 = pkgs.ghc914; ihpPackageNames = [ "ihp-ide" "ihp-hsx" "ihp-schema-compiler" - "ihp-postgres-parser" "ihp-context" "ihp-pagehead" + "ihp-postgres-parser" "ihp-pagehead" "ihp-log" "ihp-modal" "ihp-mail" "ihp-migrate" "ihp-openai" "ihp-ssc" "ihp-graphql" "ihp-datasync-typescript" "ihp-sitemap" diff --git a/ihp-context/IHP/ControllerContext.hs b/ihp-context/IHP/ControllerContext.hs deleted file mode 100644 index 1ec25cf0b..000000000 --- a/ihp-context/IHP/ControllerContext.hs +++ /dev/null @@ -1,170 +0,0 @@ -{-| -Module: IHP.ControllerContext -Description: Typed key-value context container with minimal dependencies -Copyright: (c) digitally induced GmbH, 2020 - -This module provides a typed key-value container where the key is the type of the value. -It only depends on base and typerep-map, making it suitable for packages that need -context storage without pulling in the full IHP dependency tree. - -The main IHP framework has heavy transitive dependencies (database, mail, logging, etc.) -through FrameworkConfig. By extracting ControllerContext into this minimal package, -other IHP packages like ihp-pagehead can have a much smaller dependency footprint. --} -module IHP.ControllerContext - ( ControllerContext(..) - , newControllerContext - , freeze - , unfreeze - , putContext - , fromContext - , maybeFromContext - , fromFrozenContext - , maybeFromFrozenContext - ) where - -import Prelude -import Data.IORef -import qualified Data.TMap as TypeMap -import qualified Data.Typeable as Typeable -import Data.Typeable (Typeable) - --- | A container storing useful data along the request lifecycle, such as the request, the current user, set current view layout, flash messages, ... --- --- The controller context is usually accessed via the @?context@ variable. It's available inside the action and the view. Think of it as a key-value-map where the key is the type of the value. --- --- You can store information inside the context using 'putContext': --- --- >>> newtype CurrentLayout = CurrentLayout Html --- >>> --- >>> ?context <- newControllerContext --- >>> putContext (CurrentLayout layout) --- --- Inside an action you can access the values using 'fromContext': --- --- >>> (CurrentLayout layout) <- fromContext --- --- You can freeze the context and then access values without being inside an IO context (like inside views which are pure): --- --- Call 'freeze' inside an IO part: --- --- >>> ?context <- freeze ?context --- --- ('freeze' is automatically called by IHP before rendering a view, so usually you don't need to call it manually) --- --- Then use the frozen context from your pure code like this: --- --- >>> let (CurrentLayout layout) = fromFrozenContext in ... --- --- The context is initially created before a action is going to be executed. Its life cycle looks like this: --- --- - @newControllerContext@: The new controller context is created --- - The 'IHP.ControllerSupport.runActionWithNewContext' fills in a few default values: The current @?application@ and also the Flash Messages to be rendered in the to-be-generated response. --- - @initContext@: The initContext function of the @InitControllerContext WebApplication@ (inside your FrontController.hs) is called. There application-specific context can be provided. Usually this is the current user and the default layout. --- - @beforeAction@: Here the context could also be modified. E.g. the layout could be overriden here for the whole controller. --- - @action ..@: The action itself. --- - Freezing: Before rendering the response, the container is frozen. Frozen means that all previously mutable fields become immutable. --- - View Rendering: The frozen container is now used inside the view and layout to display information such as the current user or flash messages -data ControllerContext - = ControllerContext { customFieldsRef :: IORef TypeMap.TMap } - | FrozenControllerContext { customFields :: TypeMap.TMap } - --- | Creates a new empty controller context -newControllerContext :: IO ControllerContext -newControllerContext = do - customFieldsRef <- newIORef TypeMap.empty - pure ControllerContext { customFieldsRef } -{-# INLINABLE newControllerContext #-} - --- | After freezing a container you can access its values from pure non-IO code by using 'fromFrozenContext' --- --- Calls to 'putContext' will throw an exception after it's frozen. -freeze :: ControllerContext -> IO ControllerContext -freeze ControllerContext { customFieldsRef } = FrozenControllerContext <$> readIORef customFieldsRef -freeze frozen = pure frozen -{-# INLINABLE freeze #-} - --- | Returns an unfrozen version of the controller context that can be modified again --- --- This is used together with 'freeze' by e.g. AutoRefresh to make an immutable copy of the current controller context state -unfreeze :: ControllerContext -> IO ControllerContext -unfreeze FrozenControllerContext { customFields } = do - customFieldsRef <- newIORef customFields - pure ControllerContext { customFieldsRef } -unfreeze ControllerContext {} = error "Cannot call unfreeze on a controller context that is not frozen" -{-# INLINABLE unfreeze #-} - --- | Returns a value from the current controller context --- --- Throws an exception if there is no value with the type inside the context --- --- __Example:__ Read the current user from the context --- --- >>> user <- fromContext @User -fromContext :: forall value. (?context :: ControllerContext, Typeable value) => IO value -fromContext = maybeFromContext @value >>= \case - Just value -> pure value - Nothing -> do - let ControllerContext { customFieldsRef } = ?context - customFields <- readIORef customFieldsRef - let notFoundMessage = buildNotFoundMessage (Typeable.typeRep (Typeable.Proxy @value)) customFields - error notFoundMessage -{-# INLINABLE fromContext #-} - --- | Returns a value from the current controller context. Requires the context to be frozen. --- --- __Example:__ Read the current user from the context --- --- >>> let user = fromFrozenContext @User -fromFrozenContext :: forall value. (?context :: ControllerContext, Typeable value) => value -fromFrozenContext = case maybeFromFrozenContext @value of - Just value -> value - Nothing -> do - let FrozenControllerContext { customFields } = ?context - let notFoundMessage = buildNotFoundMessage (Typeable.typeRep (Typeable.Proxy @value)) customFields - error notFoundMessage -{-# INLINABLE fromFrozenContext #-} - --- | Returns a value from the current controller context, or Nothing if not found -maybeFromContext :: forall value. (?context :: ControllerContext, Typeable value) => IO (Maybe value) -maybeFromContext = do - frozen <- freeze ?context - let ?context = frozen - pure (maybeFromFrozenContext @value) -{-# INLINABLE maybeFromContext #-} - --- | Returns a value from a frozen controller context, or Nothing if not found -maybeFromFrozenContext :: forall value. (?context :: ControllerContext, Typeable value) => Maybe value -maybeFromFrozenContext = case ?context of - FrozenControllerContext { customFields } -> TypeMap.lookup @value customFields - ControllerContext {} -> error ("maybeFromFrozenContext called on a non frozen context while trying to access " <> show (Typeable.typeRep (Typeable.Proxy @value))) -{-# INLINABLE maybeFromFrozenContext #-} - --- | Puts a value into the context --- --- Throws an exception if the context is already frozen. -putContext :: forall value. (?context :: ControllerContext, Typeable value) => value -> IO () -putContext value = do - let ControllerContext { customFieldsRef } = ?context - modifyIORef customFieldsRef (TypeMap.insert value) -{-# INLINABLE putContext #-} - --- | Build an improved error message when a value is not found in the context --- --- For common types that require initialization, provides helpful suggestions -buildNotFoundMessage :: Typeable.TypeRep -> TypeMap.TMap -> String -buildNotFoundMessage typeRep customFields = - let typeName = show typeRep - baseMessage = "Unable to find " <> typeName <> " in controller context: " <> show customFields - helpMessage = case lookup typeName knownTypes of - Just hint -> "\n\nHint: " <> hint - Nothing -> "" - in baseMessage <> helpMessage - where - -- Map of type names to helpful hints for initialization - knownTypes = - [ ("Maybe User", "Ensure you have called 'initAuthentication @User' in your 'initContext' function in FrontController.hs") - , ("Maybe Admin", "Ensure you have called 'initAuthentication @Admin' in your 'initContext' function in FrontController.hs") - , ("PageTitle", "Use 'setTitle' to set the page title (imported from IHP.PageHead.ControllerFunctions)") - ] -{-# INLINABLE buildNotFoundMessage #-} diff --git a/ihp-context/LICENSE b/ihp-context/LICENSE deleted file mode 100644 index 098a3a608..000000000 --- a/ihp-context/LICENSE +++ /dev/null @@ -1,21 +0,0 @@ -The MIT License (MIT) - -Copyright (c) 2020 digitally induced GmbH - -Permission is hereby granted, free of charge, to any person obtaining a copy -of this software and associated documentation files (the "Software"), to deal -in the Software without restriction, including without limitation the rights -to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -copies of the Software, and to permit persons to whom the Software is -furnished to do so, subject to the following conditions: - -The above copyright notice and this permission notice shall be included in all -copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -SOFTWARE. \ No newline at end of file diff --git a/ihp-context/default.nix b/ihp-context/default.nix deleted file mode 100644 index ef133bbf1..000000000 --- a/ihp-context/default.nix +++ /dev/null @@ -1,10 +0,0 @@ -{ mkDerivation, base, lib, typerep-map }: -mkDerivation { - pname = "ihp-context"; - version = "1.0.0"; - src = ./.; - libraryHaskellDepends = [ base typerep-map ]; - homepage = "https://ihp.digitallyinduced.com/"; - description = "Minimal typed context container for IHP"; - license = lib.licenses.mit; -} diff --git a/ihp-context/ihp-context.cabal b/ihp-context/ihp-context.cabal deleted file mode 100644 index a626bbc1c..000000000 --- a/ihp-context/ihp-context.cabal +++ /dev/null @@ -1,44 +0,0 @@ -cabal-version: 2.2 -name: ihp-context -version: 1.0.0 -synopsis: Minimal typed context container for IHP -description: - This package provides ControllerContext, a typed key-value container with minimal dependencies. - . - The main IHP framework has heavy transitive dependencies (database, mail, logging, etc.) - through FrameworkConfig. By extracting ControllerContext into this lightweight package, - other IHP packages like ihp-pagehead can depend only on ihp-context instead of the - full ihp package, significantly reducing their dependency footprint. -license: MIT -license-file: LICENSE -author: digitally induced GmbH -maintainer: hello@digitallyinduced.com -homepage: https://ihp.digitallyinduced.com/ -bug-reports: https://github.com/digitallyinduced/ihp/issues -copyright: (c) digitally induced GmbH -category: Web, IHP -stability: Stable -tested-with: GHC == 9.8.4 -build-type: Simple - -source-repository head - type: git - location: https://github.com/digitallyinduced/ihp - -common shared-properties - default-language: GHC2021 - default-extensions: - NoImplicitPrelude - , ImplicitParams - , BlockArguments - , LambdaCase - ghc-options: -Werror=incomplete-patterns -Werror=unused-imports -Werror=missing-fields - -library - import: shared-properties - hs-source-dirs: . - build-depends: - base >= 4.17.0 && < 4.22 - , typerep-map - exposed-modules: - IHP.ControllerContext diff --git a/ihp-datasync/Test/DataSync/DataSyncIntegrationSpec.hs b/ihp-datasync/Test/DataSync/DataSyncIntegrationSpec.hs index 3a02f088d..fb3218677 100644 --- a/ihp-datasync/Test/DataSync/DataSyncIntegrationSpec.hs +++ b/ihp-datasync/Test/DataSync/DataSyncIntegrationSpec.hs @@ -15,7 +15,7 @@ import IHP.DataSync.DynamicQueryCompiler (camelCaseRenamer) import IHP.DataSync.RowLevelSecurity (makeCachedEnsureRLSEnabled) import qualified IHP.DataSync.ChangeNotifications as ChangeNotifications import IHP.RequestVault (pgListenerVaultKey, frameworkConfigVaultKey, loggerVaultKey) -import IHP.Controller.Context (newControllerContext, freeze) +import IHP.Controller.Context (newControllerContext) import IHP.LoginSupport.Types (HasNewSessionUrl(..), CurrentUserRecord, currentUserVaultKey) import qualified IHP.ModelSupport as ModelSupport import IHP.ModelSupport.Types (Id'(..), PrimaryKey) @@ -162,10 +162,6 @@ withDataSyncController connStr testUserId action = do context <- newControllerContext let ?context = context - -- Freeze the context so it can be accessed from pure code - frozenContext <- freeze ?context - let ?context = frozenContext - -- Create the DataSync state IORef stateRef <- newIORef DataSyncController let ?state = stateRef diff --git a/ihp-modal/default.nix b/ihp-modal/default.nix index 9dc278d34..d64bf5f9e 100644 --- a/ihp-modal/default.nix +++ b/ihp-modal/default.nix @@ -1,13 +1,9 @@ -{ mkDerivation, base, blaze-html, ihp-context, ihp-hsx, lib, text -, vault, wai -}: +{ mkDerivation, base, blaze-html, ihp-hsx, lib, text, vault, wai }: mkDerivation { pname = "ihp-modal"; version = "1.0.0"; src = ./.; - libraryHaskellDepends = [ - base blaze-html ihp-context ihp-hsx text vault wai - ]; + libraryHaskellDepends = [ base blaze-html ihp-hsx text vault wai ]; homepage = "https://ihp.digitallyinduced.com/"; description = "Modal dialog support for IHP applications"; license = lib.licenses.mit; diff --git a/ihp-modal/ihp-modal.cabal b/ihp-modal/ihp-modal.cabal index 4c13c31ce..3ce3a45b1 100644 --- a/ihp-modal/ihp-modal.cabal +++ b/ihp-modal/ihp-modal.cabal @@ -3,7 +3,7 @@ name: ihp-modal version: 1.0.0 synopsis: Modal dialog support for IHP applications description: Provides modal dialog functionality with Bootstrap-compatible markup. - Can be used with the full IHP framework or standalone with ihp-context and ihp-hsx. + Can be used with the full IHP framework or standalone with ihp-hsx. license: MIT license-file: LICENSE author: digitally induced GmbH @@ -17,7 +17,6 @@ common shared-properties default-language: GHC2021 build-depends: base >= 4.17.0 && < 4.22 - , ihp-context , ihp-hsx , text , blaze-html diff --git a/ihp-pagehead/default.nix b/ihp-pagehead/default.nix index 5aa1f210e..c2ba18cd1 100644 --- a/ihp-pagehead/default.nix +++ b/ihp-pagehead/default.nix @@ -1,13 +1,9 @@ -{ mkDerivation, base, blaze-html, ihp-context, ihp-hsx, lib, text -, vault, wai -}: +{ mkDerivation, base, blaze-html, ihp-hsx, lib, text, vault, wai }: mkDerivation { pname = "ihp-pagehead"; version = "1.0.0"; src = ./.; - libraryHaskellDepends = [ - base blaze-html ihp-context ihp-hsx text vault wai - ]; + libraryHaskellDepends = [ base blaze-html ihp-hsx text vault wai ]; homepage = "https://ihp.digitallyinduced.com/"; description = "Page title and meta tags for IHP"; license = lib.licenses.mit; diff --git a/ihp-pagehead/ihp-pagehead.cabal b/ihp-pagehead/ihp-pagehead.cabal index da189805b..b34d37685 100644 --- a/ihp-pagehead/ihp-pagehead.cabal +++ b/ihp-pagehead/ihp-pagehead.cabal @@ -4,7 +4,7 @@ version: 1.0.0 synopsis: Page title and meta tags for IHP description: Manage page titles and Open Graph meta tags in IHP applications. - This is a lightweight package depending only on ihp-context, ihp-hsx, and blaze-html. + This is a lightweight package depending only on ihp-hsx and blaze-html. license: MIT license-file: LICENSE author: digitally induced GmbH @@ -38,7 +38,6 @@ library hs-source-dirs: . build-depends: base >= 4.17.0 && < 4.22 - , ihp-context , ihp-hsx , text , blaze-html diff --git a/ihp/IHP/AutoRefresh.hs b/ihp/IHP/AutoRefresh.hs index 847162180..2cdc3a701 100644 --- a/ihp/IHP/AutoRefresh.hs +++ b/ihp/IHP/AutoRefresh.hs @@ -78,18 +78,15 @@ autoRefresh runAction = do let newRequest = ?request { vault = Vault.insert autoRefreshStateVaultKey (AutoRefreshEnabled id) ?request.vault } let ?request = newRequest - -- We save the current state of the controller context here. This includes e.g. all current - -- flash messages, the current user, ... - -- - -- This frozen context is used as a "template" inside renderView to make a new controller context - -- with the exact same content we had when rendering the initial page, whenever we do a server-side re-rendering - frozenControllerContext <- freeze ?context - + -- Capture the current request and context for re-rendering. The + -- request vault carries all per-request state (current user, flash + -- messages, framework config, ...) so passing the closure-captured + -- values back into the renderView callback is enough. let originalRequest = ?request + let originalContext = ?context let renderView = \waiRequest waiRespond -> do earlyReturnMiddleware (\_ respond -> do - controllerContext <- unfreeze frozenControllerContext - let ?context = controllerContext + let ?context = originalContext let ?request = originalRequest let ?respond = respond action ?theAction diff --git a/ihp/IHP/Controller/Context.hs b/ihp/IHP/Controller/Context.hs index ba0a444ea..36ab12202 100644 --- a/ihp/IHP/Controller/Context.hs +++ b/ihp/IHP/Controller/Context.hs @@ -2,70 +2,42 @@ Module: IHP.Controller.Context Copyright: (c) digitally induced GmbH, 2020 -Re-exports from ihp-context and adds IHP-specific HasField instances -for accessing the WAI Request and FrameworkConfig. +A thin wrapper around the WAI 'Request' that's threaded through controllers +and views as the @?context@ implicit parameter. All request-scoped state +lives in @request.vault@ now; see 'IHP.RequestVault'. -} module IHP.Controller.Context ( ControllerContext(..) , newControllerContext - , freeze - , unfreeze - , putContext - , fromContext - , maybeFromContext - , fromFrozenContext - , maybeFromFrozenContext , ActionType(..) ) where import Prelude -import Data.IORef (newIORef, readIORef) import GHC.Records (HasField(..)) -import qualified Data.TMap as TypeMap import IHP.FrameworkConfig.Types (FrameworkConfig(..)) import IHP.Log.Types -import System.IO.Unsafe (unsafePerformIO) import Network.Wai (Request) import IHP.RequestVault (requestFrameworkConfig, requestLogger) import IHP.ActionType (ActionType(..)) --- Re-export from ihp-context, but we shadow newControllerContext -import IHP.ControllerContext (ControllerContext(..), freeze, unfreeze, putContext, fromContext, maybeFromContext, fromFrozenContext, maybeFromFrozenContext) - --- | Creates a new controller context with the WAI Request stored in the TMap +-- | Wraps the WAI 'Request' that's threaded through controllers and views. -- --- This version stores the Request in the TMap so it can be retrieved --- via the HasField instance. +-- The @request@ field accessor lets you write @?context.request@. Other +-- common fields (@frameworkConfig@, @logger@) are provided via 'HasField' +-- instances that delegate to the underlying request vault. +data ControllerContext = ControllerContext { request :: Request } + +-- | Creates a controller context wrapping the current request. newControllerContext :: (?request :: Request) => IO ControllerContext -newControllerContext = do - customFieldsRef <- newIORef (TypeMap.insert ?request TypeMap.empty) - pure ControllerContext { customFieldsRef } +newControllerContext = pure ControllerContext { request = ?request } {-# INLINE newControllerContext #-} --- | Access request from the TMap --- --- This allows @controllerContext.request@ to work by retrieving --- the WAI Request stored in the TMap. -instance HasField "request" ControllerContext Request where - getField (FrozenControllerContext { customFields }) = - case TypeMap.lookup @Request customFields of - Just req -> req - Nothing -> error "request: Request not found in controller context. Did you forget to call newControllerContext?" - getField (ControllerContext { customFieldsRef }) = - -- Hacky but necessary - we need to read the IORef in a pure context - unsafePerformIO $ do - customFields <- readIORef customFieldsRef - case TypeMap.lookup @Request customFields of - Just req -> pure req - Nothing -> error "request: Request not found in controller context. Did you forget to call newControllerContext?" - {-# INLINABLE getField #-} - --- | Access frameworkConfig via the request vault +-- | @?context.frameworkConfig@ delegates to @?context.request.frameworkConfig@. instance HasField "frameworkConfig" ControllerContext FrameworkConfig where - getField controllerContext = requestFrameworkConfig controllerContext.request + getField context = requestFrameworkConfig context.request {-# INLINABLE getField #-} --- | Access logger from the request vault +-- | @?context.logger@ delegates to @?context.request.logger@. instance HasField "logger" ControllerContext Logger where getField context = requestLogger context.request {-# INLINABLE getField #-} diff --git a/ihp/IHP/Controller/Render.hs b/ihp/IHP/Controller/Render.hs index 0e2170305..0d04ceb83 100644 --- a/ihp/IHP/Controller/Render.hs +++ b/ihp/IHP/Controller/Render.hs @@ -11,7 +11,6 @@ import qualified Network.HTTP.Media as Accept import IHP.HSX.Markup (Markup, MarkupM(..)) -import qualified IHP.Controller.Context as Context import IHP.Controller.Layout import IHP.FlashMessages (consumeFlashMessagesMiddleware) @@ -35,13 +34,8 @@ renderHtml :: forall view. (ViewSupport.View view, ?context :: ControllerContext renderHtml !view = do let ?view = view ViewSupport.beforeRender view - frozenContext <- Context.freeze ?context - - let ?context = frozenContext (ViewLayout layout) <- getLayout - - let boundHtml = let ?context = frozenContext; in layout (ViewSupport.html ?view) - pure boundHtml + pure (layout (ViewSupport.html ?view)) {-# INLINE renderHtml #-} renderFile :: (?request :: Request, ?respond :: Respond) => String -> ByteString -> IO ResponseReceived diff --git a/ihp/IHP/LoginSupport/Middleware.hs b/ihp/IHP/LoginSupport/Middleware.hs index 55cfcf30e..e1e327adc 100644 --- a/ihp/IHP/LoginSupport/Middleware.hs +++ b/ihp/IHP/LoginSupport/Middleware.hs @@ -1,8 +1,7 @@ {-# LANGUAGE AllowAmbiguousTypes #-} module IHP.LoginSupport.Middleware - ( initAuthentication - , authMiddleware + ( authMiddleware , adminAuthMiddleware , userIdMiddleware , adminIdMiddleware @@ -22,7 +21,6 @@ import IHP.Prelude import IHP.LoginSupport.Types import IHP.LoginSupport.Helper.Controller (sessionKey) import IHP.Controller.Session -import IHP.Controller.Context import IHP.ControllerSupport import IHP.QueryBuilder import IHP.Fetch @@ -213,26 +211,3 @@ authMiddlewareWith key fetchUser app req respond = do let req' = req { Wai.vault = Vault.insert key user (Wai.vault req) } app req' respond {-# INLINE authMiddlewareWith #-} - --- | Legacy function for backward compatibility. --- --- Fetches the user from the session and stores it in the controller context. --- New code should use 'authMiddleware' in Config.hs instead. -{-# INLINE initAuthentication #-} -initAuthentication :: forall user normalizedModel. - ( ?context :: ControllerContext - , ?request :: Request - , ?modelContext :: ModelContext - , normalizedModel ~ NormalizeModel user - , Typeable normalizedModel - , Table normalizedModel - , FromRowHasql normalizedModel - , PrimaryKey (GetTableName normalizedModel) ~ UUID - , GetTableName normalizedModel ~ GetTableName user - , FilterPrimaryKey (GetTableName normalizedModel) - , KnownSymbol (GetModelName user) - ) => IO () -initAuthentication = do - user <- getSession @(Id user) (sessionKey @user) - >>= fetchOneOrNothing - putContext user diff --git a/ihp/IHP/RouterSupport.hs b/ihp/IHP/RouterSupport.hs index 42b982be2..45ae3ec2e 100644 --- a/ihp/IHP/RouterSupport.hs +++ b/ihp/IHP/RouterSupport.hs @@ -79,7 +79,6 @@ import GHC.TypeLits as T import IHP.Controller.Context import IHP.Controller.Param import Data.Kind -import qualified Data.TMap as TypeMap import Network.Wai.Middleware.EarlyReturn (earlyReturnMiddleware) -- | Binds @?request@ and @?respond@ from WAI arguments, then runs the given action. @@ -1108,10 +1107,8 @@ parseIntegerId queryVal = let -- routeParam :: (?request :: Request, ?respond :: Respond, ParamReader paramType) => ByteString -> paramType routeParam paramName = - let customFields = TypeMap.insert ?request TypeMap.empty - in - let ?context = FrozenControllerContext { customFields } - in param paramName + let ?context = ControllerContext { request = ?request } + in param paramName -- | Display a better error when the user missed to pass an argument to an action. -- diff --git a/ihp/Test/Test/Controller/ContextSpec.hs b/ihp/Test/Test/Controller/ContextSpec.hs deleted file mode 100644 index 0531348cf..000000000 --- a/ihp/Test/Test/Controller/ContextSpec.hs +++ /dev/null @@ -1,112 +0,0 @@ -{-| -Module: Test.Controller.ContextSpec -Copyright: (c) digitally induced GmbH, 2020 --} -module Test.Controller.ContextSpec where - -import Test.Hspec -import IHP.Prelude -import IHP.Controller.Context -import Wai.Request.Params.Middleware (RequestBody (..), Respond) -import Control.Exception -import Network.Wai.Internal (ResponseReceived(..)) -import Network.Wai.Test (defaultRequest) -import qualified Data.Vault.Lazy as Vault -import IHP.RequestVault (requestBodyVaultKey) -import Network.Wai (vault) -import qualified Data.List as List - --- Test types to simulate known types in error messages -data PageTitle = PageTitle deriving (Typeable) - -tests = do - let requestBody = FormBody [] [] "" - let mockRequest = defaultRequest { vault = Vault.insert requestBodyVaultKey requestBody (vault defaultRequest) } - let mockRespond :: Respond - mockRespond = \_ -> pure ResponseReceived - let ?request = mockRequest - let ?respond = mockRespond - describe "IHP.Controller.Context" do - describe "putContext" do - it "store a value" do - context <- newControllerContext - let ?context = context - putContext ("hello" :: Text) - - it "fails if called on a frozen context" do - context <- newControllerContext >>= freeze - let ?context = context - putContext ("hello" :: Text) `shouldThrow` anyException - - describe "fromContext" do - it "return a stored value" do - context <- newControllerContext - let ?context = context - - putContext ("hello" :: Text) - - result <- fromContext @Text - result `shouldBe` "hello" - - it "should fail if type not in container" do - context <- newControllerContext - let ?context = context - - (fromContext @Text) `shouldThrow` (\e -> case e of - ErrorCall msg -> "Unable to find Text in controller context:" `List.isPrefixOf` msg - _ -> False) - - it "return a stored value if frozen" do - context <- newControllerContext - let ?context = context - - putContext ("hello" :: Text) - context <- freeze ?context - let ?context = context - - result <- fromContext @Text - result `shouldBe` "hello" - - describe "fromFrozenContext" do - it "sohuld fail if not frozen" do - context <- newControllerContext - let ?context = context - - putContext ("hello" :: Text) - - let result = fromFrozenContext @Text - (evaluate result) `shouldThrow` (errorCall "maybeFromFrozenContext called on a non frozen context while trying to access Text") - - it "return a stored value" do - context <- newControllerContext - let ?context = context - - putContext ("hello" :: Text) - - context <- freeze ?context - - let ?context = context - - (fromFrozenContext @Text) `shouldBe` "hello" - - it "should provide helpful error message for known types" do - context <- newControllerContext - let ?context = context - - -- Test that error message does not include a hint for unknown types - (fromContext @Int) `shouldThrow` (\e -> case e of - ErrorCall msg -> - "Unable to find" `List.isPrefixOf` msg && - not ("Hint:" `List.isInfixOf` msg) -- Int is not a known type, so no hint - _ -> False) - - it "should provide hint for PageTitle" do - context <- newControllerContext - let ?context = context - - -- Test that PageTitle gets the correct hint - (fromContext @PageTitle) `shouldThrow` (\e -> case e of - ErrorCall msg -> - "Unable to find PageTitle in controller context:" `List.isPrefixOf` msg && - "Hint: Use 'setTitle' to set the page title (imported from IHP.PageHead.ControllerFunctions)" `List.isInfixOf` msg - _ -> False) diff --git a/ihp/Test/Test/Controller/ParamSpec.hs b/ihp/Test/Test/Controller/ParamSpec.hs index 874893cf5..3a87e107b 100644 --- a/ihp/Test/Test/Controller/ParamSpec.hs +++ b/ihp/Test/Test/Controller/ParamSpec.hs @@ -468,15 +468,13 @@ createControllerContextWithParams params = let requestBody = FormBody { params, files = [], rawPayload = "" } request = Wai.defaultRequest { Wai.vault = Vault.insert requestBodyVaultKey requestBody Vault.empty } - customFields = TypeMap.insert request TypeMap.empty - in FrozenControllerContext { customFields } + in ControllerContext { request } createControllerContextWithJson params = let requestBody = JSONBody { jsonPayload = Just (json params), rawPayload = cs params } request = Wai.defaultRequest { Wai.vault = Vault.insert requestBodyVaultKey requestBody Vault.empty } - customFields = TypeMap.insert request TypeMap.empty - in FrozenControllerContext { customFields } + in ControllerContext { request } json :: Text -> Aeson.Value json string = diff --git a/ihp/Test/Test/Main.hs b/ihp/Test/Test/Main.hs index 90c4b5608..ba22d2a0c 100644 --- a/ihp/Test/Test/Main.hs +++ b/ihp/Test/Test/Main.hs @@ -8,7 +8,6 @@ import qualified Test.NameSupportSpec import qualified Test.HaskellSupportSpec import qualified Test.View.CSSFrameworkSpec 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 @@ -35,7 +34,6 @@ main = hspec do Test.HaskellSupportSpec.tests Test.View.CSSFrameworkSpec.tests Test.View.FormSpec.tests - Test.Controller.ContextSpec.tests Test.Controller.ParamSpec.tests Test.Controller.AccessDeniedSpec.tests Test.Controller.NotFoundSpec.tests diff --git a/ihp/Test/Test/Pagination/ControllerFunctionsSpec.hs b/ihp/Test/Test/Pagination/ControllerFunctionsSpec.hs index 209b12391..0f66037c2 100644 --- a/ihp/Test/Test/Pagination/ControllerFunctionsSpec.hs +++ b/ihp/Test/Test/Pagination/ControllerFunctionsSpec.hs @@ -141,8 +141,7 @@ contextWithParams :: [(ByteString, ByteString)] -> ControllerContext contextWithParams params = let requestBody = FormBody { params, files = [], rawPayload = "" } request = Wai.defaultRequest { Wai.vault = Vault.insert requestBodyVaultKey requestBody Vault.empty } - customFields = TypeMap.insert request TypeMap.empty - in FrozenControllerContext { customFields } + in ControllerContext { request } -- | Run a test with a database connection, skipping if PostgreSQL is not available. -- Only connection failures are caught and marked as pending; test assertion errors propagate normally. diff --git a/ihp/Test/Test/RouterSupportSpec.hs b/ihp/Test/Test/RouterSupportSpec.hs index d25ecf723..516097b7b 100644 --- a/ihp/Test/Test/RouterSupportSpec.hs +++ b/ihp/Test/Test/RouterSupportSpec.hs @@ -14,7 +14,7 @@ import IHP.Environment import IHP.FrameworkConfig import IHP.RouterSupport hiding (get) import Data.Attoparsec.ByteString.Char8 (string, endOfInput) -import IHP.ViewPrelude +import IHP.ViewPrelude hiding (request) import IHP.ControllerPrelude hiding (get, request) import Network.Wai.Test import Network.HTTP.Types diff --git a/ihp/Test/Test/View/CSSFrameworkSpec.hs b/ihp/Test/Test/View/CSSFrameworkSpec.hs index 156929ec2..fe71a374a 100644 --- a/ihp/Test/Test/View/CSSFrameworkSpec.hs +++ b/ihp/Test/Test/View/CSSFrameworkSpec.hs @@ -725,5 +725,4 @@ createControllerContextWithCSSFramework cssFramework = do let requestBody = FormBody { params = [], files = [], rawPayload = "" } let request = Wai.defaultRequest { Wai.vault = Vault.insert IHP.RequestVault.frameworkConfigVaultKey frameworkConfig $ Vault.insert IHP.RequestVault.requestBodyVaultKey requestBody Vault.empty } - let customFields = TypeMap.insert request TypeMap.empty - pure FrozenControllerContext { customFields } \ No newline at end of file + pure ControllerContext { request } \ No newline at end of file diff --git a/ihp/Test/Test/View/FormSpec.hs b/ihp/Test/Test/View/FormSpec.hs index 5ec51b916..9b97dbd62 100644 --- a/ihp/Test/Test/View/FormSpec.hs +++ b/ihp/Test/Test/View/FormSpec.hs @@ -87,8 +87,7 @@ createControllerContext = do let requestBody = FormBody { params = [], files = [], rawPayload = "" } let request = Wai.defaultRequest { Wai.vault = Vault.insert IHP.RequestVault.frameworkConfigVaultKey frameworkConfig $ Vault.insert IHP.RequestVault.requestBodyVaultKey requestBody Vault.empty } - let customFields = TypeMap.insert request TypeMap.empty - pure FrozenControllerContext { customFields } + pure ControllerContext { request } data Project' = Project {id :: (Id' "projects"), title :: Text, meta :: MetaBag} deriving (Eq, Show) instance InputValue Project where inputValue = IHP.ModelSupport.recordToInputValue diff --git a/ihp/default.nix b/ihp/default.nix index eaec8c842..88651df16 100644 --- a/ihp/default.nix +++ b/ihp/default.nix @@ -6,11 +6,11 @@ , hashable, haskell-src-exts, haskell-src-meta, hasql , hasql-dynamic-statements, hasql-implicits, hasql-mapping , hasql-pool, hasql-postgresql-types, hasql-transaction, hspec -, http-client, http-client-tls, http-media, http-types, ihp-context -, ihp-hsx, ihp-imagemagick, ihp-log, ihp-modal, ihp-pagehead -, ihp-pglistener, inflections, interpolate, lib, mime-types -, minio-hs, mono-traversable, mtl, neat-interpolation, network -, network-uri, parser-combinators, postgresql-simple +, http-client, http-client-tls, http-media, http-types, ihp-hsx +, ihp-imagemagick, ihp-log, ihp-modal, ihp-pagehead, ihp-pglistener +, inflections, interpolate, lib, mime-types, minio-hs +, mono-traversable, mtl, neat-interpolation, network, network-uri +, parser-combinators, postgresql-simple , postgresql-simple-postgresql-types, postgresql-types, process , pwstore-fast, random, random-strings, regex-tdfa, resource-pool , resourcet, safe-exceptions, scientific, slugger, split, stm @@ -35,21 +35,20 @@ mkDerivation { fast-logger filepath ghc-prim hashable haskell-src-exts haskell-src-meta hasql hasql-dynamic-statements hasql-implicits hasql-mapping hasql-pool hasql-postgresql-types hasql-transaction - http-client http-client-tls http-media http-types ihp-context - ihp-hsx ihp-imagemagick ihp-log ihp-modal ihp-pagehead - ihp-pglistener inflections interpolate mime-types minio-hs - mono-traversable mtl neat-interpolation network network-uri - parser-combinators postgresql-simple - postgresql-simple-postgresql-types postgresql-types process - pwstore-fast random random-strings regex-tdfa resource-pool - resourcet safe-exceptions scientific slugger split stm - string-conversions template-haskell text time transformers - typerep-map unagi-chan unix unliftio unordered-containers - uri-encode uuid vault vector wai wai-app-static wai-asset-path - wai-cors wai-early-return wai-extra wai-flash-messages - wai-request-params wai-session-clientsession-deferred - wai-session-maybe wai-util wai-websockets warp warp-systemd - websockets with-utf8 + http-client http-client-tls http-media http-types ihp-hsx + ihp-imagemagick ihp-log ihp-modal ihp-pagehead ihp-pglistener + inflections interpolate mime-types minio-hs mono-traversable mtl + neat-interpolation network network-uri parser-combinators + postgresql-simple postgresql-simple-postgresql-types + postgresql-types process pwstore-fast random random-strings + regex-tdfa resource-pool resourcet safe-exceptions scientific + slugger split stm string-conversions template-haskell text time + transformers typerep-map unagi-chan unix unliftio + unordered-containers uri-encode uuid vault vector wai + wai-app-static wai-asset-path wai-cors wai-early-return wai-extra + wai-flash-messages wai-request-params + wai-session-clientsession-deferred wai-session-maybe wai-util + wai-websockets warp warp-systemd websockets with-utf8 ]; testHaskellDepends = [ aeson async attoparsec base basic-prelude binary blaze-html @@ -59,21 +58,20 @@ mkDerivation { fast-logger filepath ghc-prim hashable haskell-src-exts haskell-src-meta hasql hasql-dynamic-statements hasql-implicits hasql-mapping hasql-pool hasql-postgresql-types hasql-transaction - hspec http-client http-client-tls http-media http-types ihp-context - ihp-hsx ihp-imagemagick ihp-log ihp-modal ihp-pagehead - ihp-pglistener inflections interpolate mime-types minio-hs - mono-traversable mtl neat-interpolation network network-uri - parser-combinators postgresql-simple - postgresql-simple-postgresql-types postgresql-types process - pwstore-fast random random-strings regex-tdfa resource-pool - resourcet safe-exceptions scientific slugger split stm - string-conversions template-haskell text time transformers - typerep-map unagi-chan unix unliftio unordered-containers - uri-encode uuid vault vector wai wai-app-static wai-asset-path - wai-cors wai-early-return wai-extra wai-flash-messages - wai-request-params wai-session-clientsession-deferred - wai-session-maybe wai-util wai-websockets warp warp-systemd - websockets with-utf8 + hspec http-client http-client-tls http-media http-types ihp-hsx + ihp-imagemagick ihp-log ihp-modal ihp-pagehead ihp-pglistener + inflections interpolate mime-types minio-hs mono-traversable mtl + neat-interpolation network network-uri parser-combinators + postgresql-simple postgresql-simple-postgresql-types + postgresql-types process pwstore-fast random random-strings + regex-tdfa resource-pool resourcet safe-exceptions scientific + slugger split stm string-conversions template-haskell text time + transformers typerep-map unagi-chan unix unliftio + unordered-containers uri-encode uuid vault vector wai + wai-app-static wai-asset-path wai-cors wai-early-return wai-extra + wai-flash-messages wai-request-params + wai-session-clientsession-deferred wai-session-maybe wai-util + wai-websockets warp warp-systemd websockets with-utf8 ]; benchmarkHaskellDepends = [ aeson async attoparsec base basic-prelude binary blaze-html @@ -83,16 +81,15 @@ mkDerivation { fast-logger filepath ghc-prim hashable haskell-src-exts haskell-src-meta hasql hasql-dynamic-statements hasql-implicits hasql-mapping hasql-pool hasql-postgresql-types hasql-transaction - http-client http-client-tls http-media http-types ihp-context - ihp-hsx ihp-imagemagick ihp-log ihp-modal ihp-pagehead - ihp-pglistener inflections interpolate mime-types minio-hs - mono-traversable mtl neat-interpolation network network-uri - parser-combinators postgresql-simple - postgresql-simple-postgresql-types postgresql-types process - pwstore-fast random random-strings regex-tdfa resource-pool - resourcet safe-exceptions scientific slugger split stm - string-conversions tasty-bench template-haskell text time - transformers typerep-map unagi-chan unix unliftio + http-client http-client-tls http-media http-types ihp-hsx + ihp-imagemagick ihp-log ihp-modal ihp-pagehead ihp-pglistener + inflections interpolate mime-types minio-hs mono-traversable mtl + neat-interpolation network network-uri parser-combinators + postgresql-simple postgresql-simple-postgresql-types + postgresql-types process pwstore-fast random random-strings + regex-tdfa resource-pool resourcet safe-exceptions scientific + slugger split stm string-conversions tasty-bench template-haskell + text time transformers typerep-map unagi-chan unix unliftio unordered-containers uri-encode uuid vault vector wai wai-app-static wai-asset-path wai-cors wai-early-return wai-extra wai-flash-messages wai-request-params diff --git a/ihp/ihp.cabal b/ihp/ihp.cabal index ab890ec49..07d9339bd 100644 --- a/ihp/ihp.cabal +++ b/ihp/ihp.cabal @@ -111,7 +111,6 @@ common shared-properties , unagi-chan , with-utf8 , ihp-hsx - , ihp-context , ihp-pagehead , ihp-log , ihp-modal @@ -294,7 +293,6 @@ test-suite tests Test.HaskellSupportSpec Test.View.CSSFrameworkSpec Test.View.FormSpec - Test.Controller.ContextSpec Test.Controller.ParamSpec Test.Controller.AccessDeniedSpec Test.Controller.NotFoundSpec From 00d1c58d884d00925a30e7a103e47e803f9425ca Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Mon, 13 Apr 2026 11:09:19 +0200 Subject: [PATCH 02/27] Fix list numbering in authentication guide after splitting step 6 Co-Authored-By: Claude Opus 4.6 (1M context) --- Guide/authentication.markdown | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/Guide/authentication.markdown b/Guide/authentication.markdown index fddbbe581..68bf13432 100644 --- a/Guide/authentication.markdown +++ b/Guide/authentication.markdown @@ -987,12 +987,12 @@ Here is a summary of every change needed to add authentication. Use this as a re - Add `import IHP.LoginSupport.Middleware` - Add `option $ AuthMiddleware (authMiddleware @User)` -7. Add `ensureIsUser` to `beforeAction` in any controller that requires login. +8. Add `ensureIsUser` to `beforeAction` in any controller that requires login. -8. Add a logout link in your layout: `Logout` +9. Add a logout link in your layout: `Logout` -9. (Optional) Create a registration controller and view for user sign-up. +10. (Optional) Create a registration controller and view for user sign-up. -10. (Optional) Set up password reset flow with token generation and email. +11. (Optional) Set up password reset flow with token generation and email. [Next: Authorization](https://ihp.digitallyinduced.com/Guide/authorization.html) From e4870ad0df864a62bf15aa96dc94883103ae8c14 Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Mon, 13 Apr 2026 11:11:02 +0200 Subject: [PATCH 03/27] Drop unused imports flagged by CI's Werror=unused-imports Co-Authored-By: Claude Opus 4.6 (1M context) --- ihp/IHP/AutoRefresh.hs | 1 - ihp/IHP/LoginSupport/Middleware.hs | 1 - 2 files changed, 2 deletions(-) diff --git a/ihp/IHP/AutoRefresh.hs b/ihp/IHP/AutoRefresh.hs index 2cdc3a701..c64c016f7 100644 --- a/ihp/IHP/AutoRefresh.hs +++ b/ihp/IHP/AutoRefresh.hs @@ -20,7 +20,6 @@ import qualified Control.Concurrent.MVar as MVar import qualified Data.Maybe as Maybe import qualified Data.Text as Text import IHP.WebSocket -import IHP.Controller.Context import Network.Wai.Middleware.EarlyReturn (earlyReturnMiddleware) import qualified IHP.PGListener as PGListener import qualified Hasql.Session as HasqlSession diff --git a/ihp/IHP/LoginSupport/Middleware.hs b/ihp/IHP/LoginSupport/Middleware.hs index e1e327adc..5ae3df08e 100644 --- a/ihp/IHP/LoginSupport/Middleware.hs +++ b/ihp/IHP/LoginSupport/Middleware.hs @@ -21,7 +21,6 @@ import IHP.Prelude import IHP.LoginSupport.Types import IHP.LoginSupport.Helper.Controller (sessionKey) import IHP.Controller.Session -import IHP.ControllerSupport import IHP.QueryBuilder import IHP.Fetch import IHP.ModelSupport From 2660a999a01c6dfacebe6982d3ce55523bea3a0e Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Mon, 13 Apr 2026 11:13:53 +0200 Subject: [PATCH 04/27] Drop unused Data.TMap imports from test files Co-Authored-By: Claude Opus 4.6 (1M context) --- ihp/Test/Test/Controller/ParamSpec.hs | 1 - ihp/Test/Test/Pagination/ControllerFunctionsSpec.hs | 1 - ihp/Test/Test/View/CSSFrameworkSpec.hs | 1 - ihp/Test/Test/View/FormSpec.hs | 1 - 4 files changed, 4 deletions(-) diff --git a/ihp/Test/Test/Controller/ParamSpec.hs b/ihp/Test/Test/Controller/ParamSpec.hs index 3a87e107b..71b1bf785 100644 --- a/ihp/Test/Test/Controller/ParamSpec.hs +++ b/ihp/Test/Test/Controller/ParamSpec.hs @@ -13,7 +13,6 @@ import qualified Data.Vault.Lazy as Vault import IHP.ModelSupport import Data.Bits ((.|.)) import qualified Data.Aeson as Aeson -import qualified Data.TMap as TypeMap import qualified Network.Wai as Wai import qualified GHC.IO as IO import Data.Scientific (Scientific) diff --git a/ihp/Test/Test/Pagination/ControllerFunctionsSpec.hs b/ihp/Test/Test/Pagination/ControllerFunctionsSpec.hs index 0f66037c2..9412b4ca9 100644 --- a/ihp/Test/Test/Pagination/ControllerFunctionsSpec.hs +++ b/ihp/Test/Test/Pagination/ControllerFunctionsSpec.hs @@ -11,7 +11,6 @@ import qualified IHP.Log as Log import IHP.Log.Types (LogLevel(..), LoggerSettings(..)) import Wai.Request.Params.Middleware (RequestBody (..), requestBodyVaultKey) import qualified Data.Vault.Lazy as Vault -import qualified Data.TMap as TypeMap import qualified Network.Wai as Wai import qualified Database.PostgreSQL.Simple.Types as PG import System.Environment (lookupEnv) diff --git a/ihp/Test/Test/View/CSSFrameworkSpec.hs b/ihp/Test/Test/View/CSSFrameworkSpec.hs index fe71a374a..ac7ecaf9e 100644 --- a/ihp/Test/Test/View/CSSFrameworkSpec.hs +++ b/ihp/Test/Test/View/CSSFrameworkSpec.hs @@ -17,7 +17,6 @@ import IHP.ModelSupport import IHP.Breadcrumb.ViewFunctions (breadcrumbLinkExternal, breadcrumbText, renderBreadcrumb) import IHP.Pagination.Types import qualified IHP.Prelude as Text (isInfixOf) -import qualified Data.TMap as TypeMap import qualified Network.Wai as Wai import IHP.Pagination.ViewFunctions (renderPagination) import qualified Data.Vault.Lazy as Vault diff --git a/ihp/Test/Test/View/FormSpec.hs b/ihp/Test/Test/View/FormSpec.hs index 9b97dbd62..6f26e29cd 100644 --- a/ihp/Test/Test/View/FormSpec.hs +++ b/ihp/Test/Test/View/FormSpec.hs @@ -14,7 +14,6 @@ import qualified Network.Wai as Wai import IHP.ViewPrelude import qualified Data.Vault.Lazy as Vault import qualified IHP.RequestVault -import qualified Data.TMap as TypeMap tests = do From a77a2ab47a2fee4159a670bb418d9547cbc98804 Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Mon, 13 Apr 2026 11:22:56 +0200 Subject: [PATCH 05/27] Use NoFieldSelectors on ControllerContext to avoid clash with request fn The new ControllerContext { request :: Request } auto-generated a top-level 'request' selector that shadowed IHP.ControllerSupport.request everywhere they were both in scope (e.g. Job/Dashboard.hs). NoFieldSelectors suppresses the selector function while keeping record construction syntax and HasField-based access (?context.request) working. Co-Authored-By: Claude Opus 4.6 (1M context) --- ihp/IHP/Controller/Context.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/ihp/IHP/Controller/Context.hs b/ihp/IHP/Controller/Context.hs index 36ab12202..e7bb27656 100644 --- a/ihp/IHP/Controller/Context.hs +++ b/ihp/IHP/Controller/Context.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoFieldSelectors #-} {-| Module: IHP.Controller.Context Copyright: (c) digitally induced GmbH, 2020 @@ -22,9 +23,11 @@ import IHP.ActionType (ActionType(..)) -- | Wraps the WAI 'Request' that's threaded through controllers and views. -- --- The @request@ field accessor lets you write @?context.request@. Other --- common fields (@frameworkConfig@, @logger@) are provided via 'HasField' --- instances that delegate to the underlying request vault. +-- @?context.request@ works via 'HasField'. The @request@ label is +-- intentionally not exported as a top-level selector (see 'NoFieldSelectors') +-- to avoid clashing with 'IHP.ControllerSupport.request'. +-- Other common fields (@frameworkConfig@, @logger@) are also provided via +-- 'HasField' instances that delegate to the underlying request vault. data ControllerContext = ControllerContext { request :: Request } -- | Creates a controller context wrapping the current request. From 38af3f1eb68a1d0e49548451e1300264a9f499fc Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Mon, 13 Apr 2026 11:34:07 +0200 Subject: [PATCH 06/27] Make ControllerContext a newtype It has a single constructor with a single field, so the newtype gives us zero runtime overhead over the data constructor. Co-Authored-By: Claude Opus 4.6 (1M context) --- ihp/IHP/Controller/Context.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ihp/IHP/Controller/Context.hs b/ihp/IHP/Controller/Context.hs index e7bb27656..455b012ce 100644 --- a/ihp/IHP/Controller/Context.hs +++ b/ihp/IHP/Controller/Context.hs @@ -28,7 +28,7 @@ import IHP.ActionType (ActionType(..)) -- to avoid clashing with 'IHP.ControllerSupport.request'. -- Other common fields (@frameworkConfig@, @logger@) are also provided via -- 'HasField' instances that delegate to the underlying request vault. -data ControllerContext = ControllerContext { request :: Request } +newtype ControllerContext = ControllerContext { request :: Request } -- | Creates a controller context wrapping the current request. newControllerContext :: (?request :: Request) => IO ControllerContext From d1c0178a3f3263600e414433c09ab99011c0250a Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Mon, 13 Apr 2026 12:39:32 +0200 Subject: [PATCH 07/27] Temporarily point Bench at ihp-forum branch with auth migration The ihp-forum master still uses the removed initAuthentication / fromFrozenContext API. Point the core-size benchmark at the migrate-to-auth-middleware branch until digitallyinduced/ihp-forum#21 is merged. Co-Authored-By: Claude Opus 4.6 (1M context) --- ihp/Bench/flake.nix | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ihp/Bench/flake.nix b/ihp/Bench/flake.nix index ee921c935..bfd748920 100644 --- a/ihp/Bench/flake.nix +++ b/ihp/Bench/flake.nix @@ -3,7 +3,7 @@ inputs = { ihp.url = "github:digitallyinduced/ihp"; - ihp-forum.url = "github:digitallyinduced/ihp-forum"; + ihp-forum.url = "github:digitallyinduced/ihp-forum/migrate-to-auth-middleware"; ihp-forum.flake = false; nixpkgs.follows = "ihp/nixpkgs"; }; From 269154e91d24c9cd0feaad61d204f7997481b1a5 Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Mon, 13 Apr 2026 12:51:15 +0200 Subject: [PATCH 08/27] Pin ihp-forum to specific commit sha for cache-busting Co-Authored-By: Claude Opus 4.6 (1M context) --- ihp/Bench/flake.nix | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ihp/Bench/flake.nix b/ihp/Bench/flake.nix index bfd748920..d669572c6 100644 --- a/ihp/Bench/flake.nix +++ b/ihp/Bench/flake.nix @@ -3,7 +3,7 @@ inputs = { ihp.url = "github:digitallyinduced/ihp"; - ihp-forum.url = "github:digitallyinduced/ihp-forum/migrate-to-auth-middleware"; + ihp-forum.url = "github:digitallyinduced/ihp-forum/f4d85039be61c6fea922692ea0475531dbc928d2"; ihp-forum.flake = false; nixpkgs.follows = "ihp/nixpkgs"; }; From a5feaaf422c93764688494ddc68064554ba65b2a Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Mon, 13 Apr 2026 13:04:46 +0200 Subject: [PATCH 09/27] Bump ihp-forum pin to 2dfa843 with CurrentUserRecord instances imported Co-Authored-By: Claude Opus 4.6 (1M context) --- ihp/Bench/flake.nix | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ihp/Bench/flake.nix b/ihp/Bench/flake.nix index d669572c6..476f7d331 100644 --- a/ihp/Bench/flake.nix +++ b/ihp/Bench/flake.nix @@ -3,7 +3,7 @@ inputs = { ihp.url = "github:digitallyinduced/ihp"; - ihp-forum.url = "github:digitallyinduced/ihp-forum/f4d85039be61c6fea922692ea0475531dbc928d2"; + ihp-forum.url = "github:digitallyinduced/ihp-forum/2dfa84399886aa616ed573f8b5c5b27ac7913dd2"; ihp-forum.flake = false; nixpkgs.follows = "ihp/nixpkgs"; }; From 4c7910c7722f255f3395baf3d674239c557a6a91 Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Mon, 13 Apr 2026 13:11:24 +0200 Subject: [PATCH 10/27] Bump ihp-forum pin to 62e707e (TypeInstances cycle fix) Co-Authored-By: Claude Opus 4.6 (1M context) --- ihp/Bench/flake.nix | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ihp/Bench/flake.nix b/ihp/Bench/flake.nix index 476f7d331..ffc02bbd4 100644 --- a/ihp/Bench/flake.nix +++ b/ihp/Bench/flake.nix @@ -3,7 +3,7 @@ inputs = { ihp.url = "github:digitallyinduced/ihp"; - ihp-forum.url = "github:digitallyinduced/ihp-forum/2dfa84399886aa616ed573f8b5c5b27ac7913dd2"; + ihp-forum.url = "github:digitallyinduced/ihp-forum/62e707e26c72b98223b041c9f0b41624fb44e23a"; ihp-forum.flake = false; nixpkgs.follows = "ihp/nixpkgs"; }; From dedec7854e86a79615e36a79718e1e4fffa3016b Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Mon, 13 Apr 2026 15:43:51 +0200 Subject: [PATCH 11/27] Collapse ControllerContext to a type alias for Request After the TMap removal, ControllerContext is a trivial wrapper around Request with HasField instances that just delegate back. Making it a type alias (type ControllerContext = Request) removes the newtype overhead, drops the delegating HasField instances, and simplifies newControllerContext to 'pure ?request'. Call sites that previously used '?context.request' now use '?context' directly (same value). Tests that built ControllerContext via the record constructor now return the Request they had already built. Co-Authored-By: Claude Opus 4.6 (1M context) --- ihp/IHP/AutoRefresh/View.hs | 2 +- ihp/IHP/Controller/Context.hs | 41 ++++---------- ihp/IHP/ControllerSupport.hs | 2 +- ihp/IHP/RouterSupport.hs | 4 +- ihp/IHP/WebSocket.hs | 2 +- ihp/Test/Test/Controller/ParamSpec.hs | 56 +++++++++---------- .../Pagination/ControllerFunctionsSpec.hs | 16 +++--- ihp/Test/Test/View/CSSFrameworkSpec.hs | 14 ++--- ihp/Test/Test/View/FormSpec.hs | 10 ++-- 9 files changed, 65 insertions(+), 82 deletions(-) diff --git a/ihp/IHP/AutoRefresh/View.hs b/ihp/IHP/AutoRefresh/View.hs index 9ef899b01..5fbae84f3 100644 --- a/ihp/IHP/AutoRefresh/View.hs +++ b/ihp/IHP/AutoRefresh/View.hs @@ -11,6 +11,6 @@ import Network.Wai (vault) autoRefreshMeta :: (?context :: ControllerContext) => Html autoRefreshMeta = - case Vault.lookup autoRefreshStateVaultKey ?context.request.vault of + case Vault.lookup autoRefreshStateVaultKey ?context.vault of Just (AutoRefreshEnabled { sessionId }) -> [hsx||] _ -> mempty diff --git a/ihp/IHP/Controller/Context.hs b/ihp/IHP/Controller/Context.hs index 455b012ce..2f51a22d7 100644 --- a/ihp/IHP/Controller/Context.hs +++ b/ihp/IHP/Controller/Context.hs @@ -1,46 +1,29 @@ -{-# LANGUAGE NoFieldSelectors #-} {-| Module: IHP.Controller.Context Copyright: (c) digitally induced GmbH, 2020 -A thin wrapper around the WAI 'Request' that's threaded through controllers -and views as the @?context@ implicit parameter. All request-scoped state -lives in @request.vault@ now; see 'IHP.RequestVault'. +@'ControllerContext'@ is a type alias for the WAI 'Request' — all +request-scoped state lives in @request.vault@ (see 'IHP.RequestVault'). +The alias is preserved so existing code that uses the @?context@ implicit +parameter keeps working; 'HasField' instances for @frameworkConfig@ and +@logger@ come from 'IHP.RequestVault'. -} module IHP.Controller.Context - ( ControllerContext(..) + ( ControllerContext , newControllerContext , ActionType(..) ) where import Prelude -import GHC.Records (HasField(..)) -import IHP.FrameworkConfig.Types (FrameworkConfig(..)) -import IHP.Log.Types import Network.Wai (Request) -import IHP.RequestVault (requestFrameworkConfig, requestLogger) import IHP.ActionType (ActionType(..)) +import IHP.RequestVault () -- for HasField "frameworkConfig"/"logger"/"pgListener" on Request --- | Wraps the WAI 'Request' that's threaded through controllers and views. --- --- @?context.request@ works via 'HasField'. The @request@ label is --- intentionally not exported as a top-level selector (see 'NoFieldSelectors') --- to avoid clashing with 'IHP.ControllerSupport.request'. --- Other common fields (@frameworkConfig@, @logger@) are also provided via --- 'HasField' instances that delegate to the underlying request vault. -newtype ControllerContext = ControllerContext { request :: Request } +-- | The WAI 'Request' threaded through controllers and views. +type ControllerContext = Request --- | Creates a controller context wrapping the current request. +-- | Returns the current request. Kept for source compatibility with callers +-- that previously wrapped the request in a @ControllerContext@. newControllerContext :: (?request :: Request) => IO ControllerContext -newControllerContext = pure ControllerContext { request = ?request } +newControllerContext = pure ?request {-# INLINE newControllerContext #-} - --- | @?context.frameworkConfig@ delegates to @?context.request.frameworkConfig@. -instance HasField "frameworkConfig" ControllerContext FrameworkConfig where - getField context = requestFrameworkConfig context.request - {-# INLINABLE getField #-} - --- | @?context.logger@ delegates to @?context.request.logger@. -instance HasField "logger" ControllerContext Logger where - getField context = requestLogger context.request - {-# INLINABLE getField #-} diff --git a/ihp/IHP/ControllerSupport.hs b/ihp/IHP/ControllerSupport.hs index 6efc6ffb3..936e24516 100644 --- a/ihp/IHP/ControllerSupport.hs +++ b/ihp/IHP/ControllerSupport.hs @@ -89,7 +89,7 @@ instance InitControllerContext () where runAction :: forall controller. (Controller controller, ?context :: Context.ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond) => controller -> IO ResponseReceived runAction controller = do let ?theAction = controller - let ?request = ?context.request + let ?request = ?context -- Exceptions are now caught by the error handler middleware authenticatedModelContext <- prepareRLSIfNeeded ?modelContext diff --git a/ihp/IHP/RouterSupport.hs b/ihp/IHP/RouterSupport.hs index 45ae3ec2e..c72ce9d2f 100644 --- a/ihp/IHP/RouterSupport.hs +++ b/ihp/IHP/RouterSupport.hs @@ -105,7 +105,7 @@ runAction' controller waiRequest waiRespond = context <- setupActionContext @application (Typeable.typeOf controller) request respond let ?context = context let ?respond = respond - let ?request = context.request + let ?request = context let ?modelContext = ?request.modelContext runAction controller ) waiRequest waiRespond @@ -1107,7 +1107,7 @@ parseIntegerId queryVal = let -- routeParam :: (?request :: Request, ?respond :: Respond, ParamReader paramType) => ByteString -> paramType routeParam paramName = - let ?context = ControllerContext { request = ?request } + let ?context = ?request in param paramName -- | Display a better error when the user missed to pass an argument to an action. diff --git a/ihp/IHP/WebSocket.hs b/ihp/IHP/WebSocket.hs index 83516db1e..bbe940b95 100644 --- a/ihp/IHP/WebSocket.hs +++ b/ihp/IHP/WebSocket.hs @@ -63,7 +63,7 @@ startWSApp :: forall state. (WSApp state, ?context :: ControllerContext, ?modelC startWSApp initialState connection = do state <- newIORef initialState let ?state = state - let ?request = ?context.request + let ?request = ?context result <- Exception.try ((withPingPong (defaultPingPongOptions { Websocket.pingAction = onPing @state }) connection (\connection -> let ?connection = connection in run @state)) `Exception.finally` (let ?connection = connection in onClose @state)) case result of diff --git a/ihp/Test/Test/Controller/ParamSpec.hs b/ihp/Test/Test/Controller/ParamSpec.hs index 71b1bf785..3f428ca89 100644 --- a/ihp/Test/Test/Controller/ParamSpec.hs +++ b/ihp/Test/Test/Controller/ParamSpec.hs @@ -23,113 +23,113 @@ tests = do describe "param" do it "should parse valid input" do let ?context = createControllerContextWithParams [("page", "1")] - let ?request = ?context.request + let ?request = ?context (param @Int "page") `shouldBe` 1 it "should fail on empty input" do let ?context = createControllerContextWithParams [("page", "")] - let ?request = ?context.request + let ?request = ?context (IO.evaluate (param @Int "page")) `shouldThrow` (== ParamCouldNotBeParsedException { name = "page", parserError = "has to be an integer" }) it "should fail if param not provided" do let ?context = createControllerContextWithParams [] - let ?request = ?context.request + let ?request = ?context (IO.evaluate (param @Int "page")) `shouldThrow` (== ParamNotFoundException { name = "page" }) it "should fail with a parser error on invalid input" do let ?context = createControllerContextWithParams [("page", "NaN")] - let ?request = ?context.request + let ?request = ?context (IO.evaluate (param @Int "page")) `shouldThrow` (== ParamCouldNotBeParsedException { name = "page", parserError = "has to be an integer" }) describe "paramOrNothing" do it "should parse valid input" do let ?context = createControllerContextWithParams [("referredBy", "776ab71d-327f-41b3-90a8-7b5a251c4b88")] - let ?request = ?context.request + let ?request = ?context (paramOrNothing @UUID "referredBy") `shouldBe` (Just "776ab71d-327f-41b3-90a8-7b5a251c4b88") it "should return Nothing on empty input" do let ?context = createControllerContextWithParams [("referredBy", "")] - let ?request = ?context.request + let ?request = ?context (paramOrNothing @UUID "referredBy") `shouldBe` Nothing it "should return Nothing if param not provided" do let ?context = createControllerContextWithParams [] - let ?request = ?context.request + let ?request = ?context (paramOrNothing @UUID "referredBy") `shouldBe` Nothing it "should fail with a parser error on invalid input" do let ?context = createControllerContextWithParams [("referredBy", "not a uuid")] - let ?request = ?context.request + let ?request = ?context (IO.evaluate (paramOrNothing @UUID "referredBy")) `shouldThrow` (== ParamCouldNotBeParsedException { name = "referredBy", parserError = "has to be an UUID" }) describe "paramOrDefault" do it "should parse valid input" do let ?context = createControllerContextWithParams [("page", "1")] - let ?request = ?context.request + let ?request = ?context (paramOrDefault @Int 0 "page") `shouldBe` 1 it "should return default value on empty input" do let ?context = createControllerContextWithParams [("page", "")] - let ?request = ?context.request + let ?request = ?context (paramOrDefault @Int 10 "page") `shouldBe` 10 it "should return default value if param not provided" do let ?context = createControllerContextWithParams [] - let ?request = ?context.request + let ?request = ?context (paramOrDefault @Int 10 "page") `shouldBe` 10 it "should fail with a parser error on invalid input" do let ?context = createControllerContextWithParams [("page", "NaN")] - let ?request = ?context.request + let ?request = ?context (IO.evaluate (paramOrDefault @Int 10 "page")) `shouldThrow` (== ParamCouldNotBeParsedException { name = "page", parserError = "has to be an integer" }) describe "paramList" do it "should parse valid input" do let ?context = createControllerContextWithParams [("ingredients", "milk"), ("ingredients", "egg")] - let ?request = ?context.request + let ?request = ?context (paramList @Text "ingredients") `shouldBe` ["milk", "egg"] it "should fail on invalid input" do let ?context = createControllerContextWithParams [("numbers", "1"), ("numbers", "NaN")] - let ?request = ?context.request + let ?request = ?context (IO.evaluate (paramList @Int "numbers")) `shouldThrow` (errorCall "param: Parameter 'numbers' is invalid") it "should deal with empty input" do let ?context = createControllerContextWithParams [] - let ?request = ?context.request + let ?request = ?context (paramList @Int "numbers") `shouldBe` [] describe "paramListOrNothing" do it "should parse valid input" do let ?context = createControllerContextWithParams [("ingredients", "milk"), ("ingredients", ""), ("ingredients", "egg")] - let ?request = ?context.request + let ?request = ?context (paramListOrNothing @Text "ingredients") `shouldBe` [Just "milk", Nothing, Just "egg"] it "should not fail on invalid input" do let ?context = createControllerContextWithParams [("numbers", "1"), ("numbers", "NaN")] - let ?request = ?context.request + let ?request = ?context (paramListOrNothing @Int "numbers") `shouldBe` [Just 1, Nothing] it "should deal with empty input" do let ?context = createControllerContextWithParams [] - let ?request = ?context.request + let ?request = ?context (paramListOrNothing @Int "numbers") `shouldBe` [] describe "hasParam" do it "returns True if param given" do let ?context = createControllerContextWithParams [("a", "test")] - let ?request = ?context.request + let ?request = ?context hasParam "a" `shouldBe` True it "returns True if param given but empty" do let ?context = createControllerContextWithParams [("a", "")] - let ?request = ?context.request + let ?request = ?context hasParam "a" `shouldBe` True it "returns False if param missing" do let ?context = createControllerContextWithParams [] - let ?request = ?context.request + let ?request = ?context hasParam "a" `shouldBe` False describe "ParamReader" do @@ -415,7 +415,7 @@ tests = do describe "fill" do it "should fill provided values if valid" do let ?context = createControllerContextWithParams [("boolField", "on"), ("colorField", "Red")] - let ?request = ?context.request + let ?request = ?context let emptyRecord = FillRecord { boolField = False, colorField = Yellow, meta = def } let expectedRecord = FillRecord { boolField = True, colorField = Red, meta = def { touchedFields = 3 } } @@ -425,7 +425,7 @@ tests = do it "should not touch fields if a field is missing" do let ?context = createControllerContextWithParams [("colorField", "Red")] - let ?request = ?context.request + let ?request = ?context let emptyRecord = FillRecord { boolField = False, colorField = Yellow, meta = def } let expectedRecord = FillRecord { boolField = False, colorField = Red, meta = def { touchedFields = 2 } } @@ -435,7 +435,7 @@ tests = do it "should add validation errors if the parsing fails" do let ?context = createControllerContextWithParams [("colorField", "invalid color")] - let ?request = ?context.request + let ?request = ?context let emptyRecord = FillRecord { boolField = False, colorField = Yellow, meta = def } let expectedRecord = FillRecord { boolField = False, colorField = Yellow, meta = def { annotations = [("colorField", TextViolation "Invalid value")] } } @@ -445,7 +445,7 @@ tests = do it "should deal with json values" do let ?context = createControllerContextWithJson "{\"colorField\":\"Red\",\"boolField\":true}" - let ?request = ?context.request + let ?request = ?context let emptyRecord = FillRecord { boolField = False, colorField = Yellow, meta = def } let expectedRecord = FillRecord { boolField = True, colorField = Red, meta = def { touchedFields = 3 } } @@ -455,7 +455,7 @@ tests = do it "should deal with empty json values" do let ?context = createControllerContextWithJson "{}" - let ?request = ?context.request + let ?request = ?context let emptyRecord = FillRecord { boolField = False, colorField = Yellow, meta = def } let expectedRecord = FillRecord { boolField = False, colorField = Yellow, meta = def } @@ -467,13 +467,13 @@ createControllerContextWithParams params = let requestBody = FormBody { params, files = [], rawPayload = "" } request = Wai.defaultRequest { Wai.vault = Vault.insert requestBodyVaultKey requestBody Vault.empty } - in ControllerContext { request } + in request createControllerContextWithJson params = let requestBody = JSONBody { jsonPayload = Just (json params), rawPayload = cs params } request = Wai.defaultRequest { Wai.vault = Vault.insert requestBodyVaultKey requestBody Vault.empty } - in ControllerContext { request } + in request json :: Text -> Aeson.Value json string = diff --git a/ihp/Test/Test/Pagination/ControllerFunctionsSpec.hs b/ihp/Test/Test/Pagination/ControllerFunctionsSpec.hs index 9412b4ca9..3bb956ad0 100644 --- a/ihp/Test/Test/Pagination/ControllerFunctionsSpec.hs +++ b/ihp/Test/Test/Pagination/ControllerFunctionsSpec.hs @@ -23,7 +23,7 @@ tests = do it "should return first page with default options" $ withDB \modelContext -> do let ?modelContext = modelContext let ?context = contextWithParams [] - let ?request = ?context.request + let ?request = ?context (results :: [PG.Only Int32], pagination) <- paginatedSqlQueryWithOptions @@ -39,7 +39,7 @@ tests = do it "should return second page" $ withDB \modelContext -> do let ?modelContext = modelContext let ?context = contextWithParams [("page", "2")] - let ?request = ?context.request + let ?request = ?context (results :: [PG.Only Int32], pagination) <- paginatedSqlQueryWithOptions @@ -58,7 +58,7 @@ tests = do it "should respect maxItems from request param" $ withDB \modelContext -> do let ?modelContext = modelContext let ?context = contextWithParams [("maxItems", "10")] - let ?request = ?context.request + let ?request = ?context (results :: [PG.Only Int32], pagination) <- paginatedSqlQueryWithOptions @@ -73,7 +73,7 @@ tests = do it "should respect custom options maxItems" $ withDB \modelContext -> do let ?modelContext = modelContext let ?context = contextWithParams [] - let ?request = ?context.request + let ?request = ?context let options = Options { maxItems = 25, windowSize = 3 } (results :: [PG.Only Int32], pagination) <- @@ -89,7 +89,7 @@ tests = do it "should cap maxItems at 200" $ withDB \modelContext -> do let ?modelContext = modelContext let ?context = contextWithParams [("maxItems", "9999")] - let ?request = ?context.request + let ?request = ?context (results :: [PG.Only Int32], pagination) <- paginatedSqlQueryWithOptions @@ -104,7 +104,7 @@ tests = do it "should return empty results for page beyond data" $ withDB \modelContext -> do let ?modelContext = modelContext let ?context = contextWithParams [("page", "100")] - let ?request = ?context.request + let ?request = ?context (results :: [PG.Only Int32], pagination) <- paginatedSqlQueryWithOptions @@ -119,7 +119,7 @@ tests = do it "should handle page + maxItems together" $ withDB \modelContext -> do let ?modelContext = modelContext let ?context = contextWithParams [("page", "3"), ("maxItems", "10")] - let ?request = ?context.request + let ?request = ?context (results :: [PG.Only Int32], pagination) <- paginatedSqlQueryWithOptions @@ -140,7 +140,7 @@ contextWithParams :: [(ByteString, ByteString)] -> ControllerContext contextWithParams params = let requestBody = FormBody { params, files = [], rawPayload = "" } request = Wai.defaultRequest { Wai.vault = Vault.insert requestBodyVaultKey requestBody Vault.empty } - in ControllerContext { request } + in request -- | Run a test with a database connection, skipping if PostgreSQL is not available. -- Only connection failures are caught and marked as pending; test assertion errors propagate normally. diff --git a/ihp/Test/Test/View/CSSFrameworkSpec.hs b/ihp/Test/Test/View/CSSFrameworkSpec.hs index ac7ecaf9e..253dfd9a3 100644 --- a/ihp/Test/Test/View/CSSFrameworkSpec.hs +++ b/ihp/Test/Test/View/CSSFrameworkSpec.hs @@ -332,7 +332,7 @@ tests = do context <- createControllerContextWithCSSFramework cssFramework let ?context = context - let ?request = ?context.request + let ?request = ?context let render = renderMarkupText $ renderPagination pagination Text.isInfixOf "" @@ -631,7 +631,7 @@ tests = do context <- createControllerContextWithCSSFramework cssFramework let ?context = context - let ?request = ?context.request + let ?request = ?context let render = renderMarkupText $ renderPagination pagination Text.isInfixOf "" @@ -724,4 +724,4 @@ createControllerContextWithCSSFramework cssFramework = do let requestBody = FormBody { params = [], files = [], rawPayload = "" } let request = Wai.defaultRequest { Wai.vault = Vault.insert IHP.RequestVault.frameworkConfigVaultKey frameworkConfig $ Vault.insert IHP.RequestVault.requestBodyVaultKey requestBody Vault.empty } - pure ControllerContext { request } \ No newline at end of file + pure request \ No newline at end of file diff --git a/ihp/Test/Test/View/FormSpec.hs b/ihp/Test/Test/View/FormSpec.hs index 6f26e29cd..285f28910 100644 --- a/ihp/Test/Test/View/FormSpec.hs +++ b/ihp/Test/Test/View/FormSpec.hs @@ -24,7 +24,7 @@ tests = do it "should render a form" do context <- createControllerContext let ?context = context - let ?request = ?context.request + let ?request = ?context let form = formFor project [hsx| {textField #title} @@ -35,7 +35,7 @@ tests = do it "should render a form with a GET method" do context <- createControllerContext let ?context = context - let ?request = ?context.request + let ?request = ?context let options formContext = formContext |> set #formMethod "GET" @@ -48,7 +48,7 @@ tests = do it "should render a date field with empty value attribute when value is Nothing" do context <- createControllerContext let ?context = context - let ?request = ?context.request + let ?request = ?context let event = newRecord @Event let form = formFor event [hsx| @@ -65,7 +65,7 @@ tests = do it "should render a datetime field with empty value attribute when value is Nothing" do context <- createControllerContext let ?context = context - let ?request = ?context.request + let ?request = ?context let event = newRecord @Event let form = formFor event [hsx| @@ -86,7 +86,7 @@ createControllerContext = do let requestBody = FormBody { params = [], files = [], rawPayload = "" } let request = Wai.defaultRequest { Wai.vault = Vault.insert IHP.RequestVault.frameworkConfigVaultKey frameworkConfig $ Vault.insert IHP.RequestVault.requestBodyVaultKey requestBody Vault.empty } - pure ControllerContext { request } + pure request data Project' = Project {id :: (Id' "projects"), title :: Text, meta :: MetaBag} deriving (Eq, Show) instance InputValue Project where inputValue = IHP.ModelSupport.recordToInputValue From 7367501e74653a2e8ae376b0a50b07d3f1906d31 Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Mon, 13 Apr 2026 15:46:30 +0200 Subject: [PATCH 12/27] Drop unused IHP.Controller.Context import in RouterSupport Co-Authored-By: Claude Opus 4.6 (1M context) --- ihp/IHP/RouterSupport.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/ihp/IHP/RouterSupport.hs b/ihp/IHP/RouterSupport.hs index c72ce9d2f..2f5ee65e2 100644 --- a/ihp/IHP/RouterSupport.hs +++ b/ihp/IHP/RouterSupport.hs @@ -76,7 +76,6 @@ import qualified Data.HashMap.Strict as HashMap import IHP.WebSocket (WSApp) import qualified IHP.WebSocket as WS import GHC.TypeLits as T -import IHP.Controller.Context import IHP.Controller.Param import Data.Kind import Network.Wai.Middleware.EarlyReturn (earlyReturnMiddleware) From 689c1553a22a7f4b0b8f3fb72ba77a3cd882ce5e Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Mon, 13 Apr 2026 15:50:44 +0200 Subject: [PATCH 13/27] Drop unused imports and update test type signatures to Request Since ControllerContext is now a type alias for Request, the tests that still annotated helper types with ControllerContext need to either import it or switch to Request directly. Picked Request for clarity. Co-Authored-By: Claude Opus 4.6 (1M context) --- ihp/Test/Test/Controller/ParamSpec.hs | 1 - ihp/Test/Test/Pagination/ControllerFunctionsSpec.hs | 5 ++--- ihp/Test/Test/View/CSSFrameworkSpec.hs | 3 +-- 3 files changed, 3 insertions(+), 6 deletions(-) diff --git a/ihp/Test/Test/Controller/ParamSpec.hs b/ihp/Test/Test/Controller/ParamSpec.hs index 3f428ca89..f539b5e0e 100644 --- a/ihp/Test/Test/Controller/ParamSpec.hs +++ b/ihp/Test/Test/Controller/ParamSpec.hs @@ -7,7 +7,6 @@ module Test.Controller.ParamSpec where import IHP.Prelude import Test.Hspec import IHP.Controller.Param -import IHP.Controller.Context import Wai.Request.Params.Middleware (RequestBody (..), requestBodyVaultKey) import qualified Data.Vault.Lazy as Vault import IHP.ModelSupport diff --git a/ihp/Test/Test/Pagination/ControllerFunctionsSpec.hs b/ihp/Test/Test/Pagination/ControllerFunctionsSpec.hs index 3bb956ad0..129c7f389 100644 --- a/ihp/Test/Test/Pagination/ControllerFunctionsSpec.hs +++ b/ihp/Test/Test/Pagination/ControllerFunctionsSpec.hs @@ -4,7 +4,6 @@ import IHP.Prelude import Test.Hspec import IHP.Pagination.ControllerFunctions import IHP.Pagination.Types (Options(..), Pagination(..)) -import IHP.Controller.Context import IHP.ModelSupport (createModelContext, releaseModelContext, HasqlError(..)) import qualified Hasql.Pool as HasqlPool import qualified IHP.Log as Log @@ -135,8 +134,8 @@ tests = do (PG.Only first : _) -> first `shouldBe` 21 _ -> expectationFailure "Expected non-empty results" --- | Create a ControllerContext with the given request params -contextWithParams :: [(ByteString, ByteString)] -> ControllerContext +-- | Create a Request with the given params +contextWithParams :: [(ByteString, ByteString)] -> Wai.Request contextWithParams params = let requestBody = FormBody { params, files = [], rawPayload = "" } request = Wai.defaultRequest { Wai.vault = Vault.insert requestBodyVaultKey requestBody Vault.empty } diff --git a/ihp/Test/Test/View/CSSFrameworkSpec.hs b/ihp/Test/Test/View/CSSFrameworkSpec.hs index 253dfd9a3..889a19367 100644 --- a/ihp/Test/Test/View/CSSFrameworkSpec.hs +++ b/ihp/Test/Test/View/CSSFrameworkSpec.hs @@ -6,7 +6,6 @@ module Test.View.CSSFrameworkSpec where import Test.Hspec import IHP.Prelude -import IHP.Controller.Context import IHP.FrameworkConfig as FrameworkConfig import Wai.Request.Params.Middleware (RequestBody (..)) import IHP.View.Types @@ -717,7 +716,7 @@ shouldRenderTo renderFunction expectedHtml = renderMarkupText renderFunction `sh {-| Mock a Controller context with CSSFramework. -} -createControllerContextWithCSSFramework :: Typeable option => option -> IO ControllerContext +createControllerContextWithCSSFramework :: Typeable option => option -> IO Wai.Request createControllerContextWithCSSFramework cssFramework = do frameworkConfig <- FrameworkConfig.buildFrameworkConfig do option cssFramework From e18342222f9fc77e9aa67f1ddde4f27e40b7a823 Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Mon, 13 Apr 2026 16:21:01 +0200 Subject: [PATCH 14/27] =?UTF-8?q?Delete=20IHP.Controller.Context=20module?= =?UTF-8?q?=20=E2=80=94=20type=20alias=20inlined=20into=20ControllerSuppor?= =?UTF-8?q?t?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit ControllerContext was a one-line type alias for Request and a trivial 'newControllerContext = pure ?request' wrapper. Inline the alias into IHP.ControllerSupport (where the Controller class lives), drop the separate module, and remove the prelude re-exports. In the framework code, every type signature using ControllerContext is mass-renamed to Request directly. ?context stays as an implicit param (needed for Log/urlTo's polymorphic ConfigProvider/LoggingProvider constraint), but is now plainly a Request. Co-Authored-By: Claude Opus 4.6 (1M context) --- ihp-datasync/IHP/DataSync/ControllerImpl.hs | 18 +++++----- ihp-datasync/IHP/DataSync/REST/Controller.hs | 2 +- ihp-datasync/IHP/DataSync/RowLevelSecurity.hs | 18 +++++----- .../Test/DataSync/DataSyncIntegrationSpec.hs | 6 ++-- ihp-ide/IHP/IDE/Prelude.hs | 2 +- .../IDE/SchemaDesigner/Controller/Helper.hs | 4 +-- .../View/Columns/NewForeignKey.hs | 2 +- .../IDE/SchemaDesigner/View/Policies/New.hs | 2 +- ihp-ide/IHP/IDE/ToolServer/Layout.hs | 2 +- ihp-job-dashboard/IHP/Job/Dashboard.hs | 36 +++++++++---------- ihp-job-dashboard/IHP/Job/Dashboard/Auth.hs | 2 +- ihp-job-dashboard/IHP/Job/Dashboard/Types.hs | 4 +-- ihp-job-dashboard/IHP/Job/Dashboard/View.hs | 6 ++-- .../IHP/SEO/Sitemap/ControllerFunctions.hs | 2 +- .../ControllerFunctions.hs | 2 +- ihp-ssc/IHP/ServerSideComponent/Types.hs | 4 +-- ihp/IHP/AuthSupport/Controller/Sessions.hs | 10 +++--- ihp/IHP/AutoRefresh.hs | 4 +-- ihp/IHP/AutoRefresh/View.hs | 5 ++- ihp/IHP/Controller/Context.hs | 29 --------------- ihp/IHP/Controller/FileUpload.hs | 2 +- ihp/IHP/Controller/Layout.hs | 5 ++- ihp/IHP/Controller/Render.hs | 8 ++--- ihp/IHP/ControllerPrelude.hs | 4 +-- ihp/IHP/ControllerSupport.hs | 34 ++++++++++-------- ihp/IHP/ErrorController.hs | 17 +++++---- ihp/IHP/FileStorage/ControllerFunctions.hs | 7 ++-- ihp/IHP/LoginSupport/Helper/Controller.hs | 14 ++++---- ihp/IHP/Pagination/ControllerFunctions.hs | 11 +++--- ihp/IHP/Pagination/ViewFunctions.hs | 4 +-- ihp/IHP/View/Form/FormFor.hs | 25 +++++++------ ihp/IHP/ViewPrelude.hs | 2 -- ihp/IHP/ViewSupport.hs | 6 ++-- ihp/IHP/WebSocket.hs | 10 +++--- .../FileStorage/ControllerFunctionsSpec.hs | 4 +-- ihp/Test/Test/View/FormSpec.hs | 2 +- ihp/ihp.cabal | 1 - 37 files changed, 138 insertions(+), 178 deletions(-) delete mode 100644 ihp/IHP/Controller/Context.hs diff --git a/ihp-datasync/IHP/DataSync/ControllerImpl.hs b/ihp-datasync/IHP/DataSync/ControllerImpl.hs index 26c8ba340..df3f44848 100644 --- a/ihp-datasync/IHP/DataSync/ControllerImpl.hs +++ b/ihp-datasync/IHP/DataSync/ControllerImpl.hs @@ -41,7 +41,7 @@ type HandleCustomMessageFn = (DataSyncResponse -> IO ()) -> DataSyncMessage -> I runDataSyncController :: ( HasField "id" CurrentUserRecord (Id' (GetTableName CurrentUserRecord)) - , ?context :: ControllerContext + , ?context :: Request , ?modelContext :: ModelContext , ?request :: Request , ?state :: IORef DataSyncController @@ -106,7 +106,7 @@ runDataSyncController hasqlPool ensureRLSEnabled installTableChangeTriggers rece buildMessageHandler :: ( HasField "id" CurrentUserRecord (Id' (GetTableName CurrentUserRecord)) - , ?context :: ControllerContext + , ?context :: Request , ?modelContext :: ModelContext , ?request :: Request , ?state :: IORef DataSyncController @@ -465,26 +465,26 @@ findTransactionById transactionId = do -- concurrent transactions. Then all database connections are removed from the connection pool and further database -- queries for other users will fail. -- -ensureBelowTransactionLimit :: (?state :: IORef DataSyncController, ?context :: ControllerContext) => IO () +ensureBelowTransactionLimit :: (?state :: IORef DataSyncController, ?context :: Request) => IO () ensureBelowTransactionLimit = do transactions <- (.transactions) <$> readIORef ?state let transactionCount = HashMap.size transactions when (transactionCount >= maxTransactionsPerConnection) do Exception.throwIO (userError ("You've reached the transaction limit of " <> cs (tshow maxTransactionsPerConnection) <> " transactions")) -ensureBelowSubscriptionsLimit :: (?state :: IORef DataSyncController, ?context :: ControllerContext) => IO () +ensureBelowSubscriptionsLimit :: (?state :: IORef DataSyncController, ?context :: Request) => IO () ensureBelowSubscriptionsLimit = do subscriptions <- (.subscriptions) <$> readIORef ?state let subscriptionsCount = HashMap.size subscriptions when (subscriptionsCount >= maxSubscriptionsPerConnection) do Exception.throwIO (userError ("You've reached the subscriptions limit of " <> cs (tshow maxSubscriptionsPerConnection) <> " subscriptions")) -maxTransactionsPerConnection :: (?context :: ControllerContext) => Int +maxTransactionsPerConnection :: (?context :: Request) => Int maxTransactionsPerConnection = case getAppConfig @DataSyncMaxTransactionsPerConnection of DataSyncMaxTransactionsPerConnection value -> value -maxSubscriptionsPerConnection :: (?context :: ControllerContext) => Int +maxSubscriptionsPerConnection :: (?context :: Request) => Int maxSubscriptionsPerConnection = case getAppConfig @DataSyncMaxSubscriptionsPerConnection of DataSyncMaxSubscriptionsPerConnection value -> value @@ -504,7 +504,7 @@ encodePatchToSetSql ren columnTypes patch = in mconcat $ List.intersperse (Snippet.sql ", ") setSnippets sqlQueryWithRLSAndTransactionId :: - ( ?context :: ControllerContext + ( ?context :: Request , ?request :: Request , Show (PrimaryKey (GetTableName CurrentUserRecord)) , HasNewSessionUrl CurrentUserRecord @@ -524,7 +524,7 @@ sqlQueryWithRLSAndTransactionId pool Nothing statement = runSession pool (sqlQue -- Use this for INSERT, UPDATE, or DELETE statements with RETURNING that need -- to return results (e.g. wrapped with 'wrapDynamicQuery'). sqlQueryWriteWithRLSAndTransactionId :: - ( ?context :: ControllerContext + ( ?context :: Request , ?request :: Request , Show (PrimaryKey (GetTableName CurrentUserRecord)) , HasNewSessionUrl CurrentUserRecord @@ -540,7 +540,7 @@ sqlQueryWriteWithRLSAndTransactionId _pool (Just transactionId) statement = do sqlQueryWriteWithRLSAndTransactionId pool Nothing statement = runSession pool (sqlQueryWriteWithRLSSession statement) sqlExecWithRLSAndTransactionId :: - ( ?context :: ControllerContext + ( ?context :: Request , ?request :: Request , Show (PrimaryKey (GetTableName CurrentUserRecord)) , HasNewSessionUrl CurrentUserRecord diff --git a/ihp-datasync/IHP/DataSync/REST/Controller.hs b/ihp-datasync/IHP/DataSync/REST/Controller.hs index a6e8b6958..f469a1368 100644 --- a/ihp-datasync/IHP/DataSync/REST/Controller.hs +++ b/ihp-datasync/IHP/DataSync/REST/Controller.hs @@ -201,7 +201,7 @@ encodeKeyMapToSetSql columnTypes hashMap = setSnippets = map encodeSetClause pairsList in mconcat $ List.intersperse (Snippet.sql ", ") setSnippets -renderErrorJson :: (?context :: ControllerContext, ?request :: Request, ?respond :: Respond) => ToJSON json => json -> IO ResponseReceived +renderErrorJson :: (?context :: Request, ?request :: Request, ?respond :: Respond) => ToJSON json => json -> IO ResponseReceived renderErrorJson json = renderJsonWithStatusCode status400 json {-# INLINABLE renderErrorJson #-} diff --git a/ihp-datasync/IHP/DataSync/RowLevelSecurity.hs b/ihp-datasync/IHP/DataSync/RowLevelSecurity.hs index b7a1b3a22..a759b76ab 100644 --- a/ihp-datasync/IHP/DataSync/RowLevelSecurity.hs +++ b/ihp-datasync/IHP/DataSync/RowLevelSecurity.hs @@ -57,7 +57,7 @@ ensureRLSEnabledSession table = do -- This is a Session-level action for use in user-managed transactions -- (e.g. after a manual @BEGIN@). setRLSConfigSession :: - ( ?context :: ControllerContext + ( ?context :: Request , ?request :: Request , Show (PrimaryKey (GetTableName CurrentUserRecord)) , HasNewSessionUrl CurrentUserRecord @@ -71,7 +71,7 @@ setRLSConfigSession = Session.statement (Role.authenticatedRole, encodedUserId) Nothing -> "" sqlQueryWithRLSSession :: - ( ?context :: ControllerContext + ( ?context :: Request , ?request :: Request , Show (PrimaryKey (GetTableName CurrentUserRecord)) , HasNewSessionUrl CurrentUserRecord @@ -93,7 +93,7 @@ sqlQueryWithRLSSession statement = -- Use this for INSERT, UPDATE, or DELETE statements with RETURNING that need -- to return results (e.g. wrapped with 'wrapDynamicQuery'). sqlQueryWriteWithRLSSession :: - ( ?context :: ControllerContext + ( ?context :: Request , ?request :: Request , Show (PrimaryKey (GetTableName CurrentUserRecord)) , HasNewSessionUrl CurrentUserRecord @@ -111,7 +111,7 @@ sqlQueryWriteWithRLSSession statement = {-# INLINE sqlQueryWriteWithRLSSession #-} sqlExecWithRLSSession :: - ( ?context :: ControllerContext + ( ?context :: Request , ?request :: Request , Show (PrimaryKey (GetTableName CurrentUserRecord)) , HasNewSessionUrl CurrentUserRecord @@ -129,7 +129,7 @@ sqlExecWithRLSSession statement = {-# INLINE sqlExecWithRLSSession #-} sqlQueryScalarWithRLSSession :: - ( ?context :: ControllerContext + ( ?context :: Request , ?request :: Request , Show (PrimaryKey (GetTableName CurrentUserRecord)) , HasNewSessionUrl CurrentUserRecord @@ -149,7 +149,7 @@ sqlQueryScalarWithRLSSession statement = -- IO API (thin wrappers) sqlQueryWithRLS :: - ( ?context :: ControllerContext + ( ?context :: Request , ?request :: Request , Show (PrimaryKey (GetTableName CurrentUserRecord)) , HasNewSessionUrl CurrentUserRecord @@ -164,7 +164,7 @@ sqlQueryWithRLS pool statement = runSession pool (sqlQueryWithRLSSession stateme -- Use this for INSERT, UPDATE, or DELETE statements with RETURNING that need -- to return results (e.g. wrapped with 'wrapDynamicQuery'). sqlQueryWriteWithRLS :: - ( ?context :: ControllerContext + ( ?context :: Request , ?request :: Request , Show (PrimaryKey (GetTableName CurrentUserRecord)) , HasNewSessionUrl CurrentUserRecord @@ -175,7 +175,7 @@ sqlQueryWriteWithRLS pool statement = runSession pool (sqlQueryWriteWithRLSSessi {-# INLINE sqlQueryWriteWithRLS #-} sqlExecWithRLS :: - ( ?context :: ControllerContext + ( ?context :: Request , ?request :: Request , Show (PrimaryKey (GetTableName CurrentUserRecord)) , HasNewSessionUrl CurrentUserRecord @@ -186,7 +186,7 @@ sqlExecWithRLS pool statement = runSession pool (sqlExecWithRLSSession statement {-# INLINE sqlExecWithRLS #-} sqlQueryScalarWithRLS :: - ( ?context :: ControllerContext + ( ?context :: Request , ?request :: Request , Show (PrimaryKey (GetTableName CurrentUserRecord)) , HasNewSessionUrl CurrentUserRecord diff --git a/ihp-datasync/Test/DataSync/DataSyncIntegrationSpec.hs b/ihp-datasync/Test/DataSync/DataSyncIntegrationSpec.hs index fb3218677..6707369bb 100644 --- a/ihp-datasync/Test/DataSync/DataSyncIntegrationSpec.hs +++ b/ihp-datasync/Test/DataSync/DataSyncIntegrationSpec.hs @@ -15,7 +15,6 @@ import IHP.DataSync.DynamicQueryCompiler (camelCaseRenamer) import IHP.DataSync.RowLevelSecurity (makeCachedEnsureRLSEnabled) import qualified IHP.DataSync.ChangeNotifications as ChangeNotifications import IHP.RequestVault (pgListenerVaultKey, frameworkConfigVaultKey, loggerVaultKey) -import IHP.Controller.Context (newControllerContext) import IHP.LoginSupport.Types (HasNewSessionUrl(..), CurrentUserRecord, currentUserVaultKey) import qualified IHP.ModelSupport as ModelSupport import IHP.ModelSupport.Types (Id'(..), PrimaryKey) @@ -157,10 +156,9 @@ withDataSyncController connStr testUserId action = do |> Vault.insert currentUserVaultKey testUser let request = defaultRequest { vault = v } - -- Set up ControllerContext with the request and current user + -- Set up the request and current user let ?request = request - context <- newControllerContext - let ?context = context + let ?context = ?request -- Create the DataSync state IORef stateRef <- newIORef DataSyncController diff --git a/ihp-ide/IHP/IDE/Prelude.hs b/ihp-ide/IHP/IDE/Prelude.hs index 5fd0969a2..8160164e1 100644 --- a/ihp-ide/IHP/IDE/Prelude.hs +++ b/ihp-ide/IHP/IDE/Prelude.hs @@ -34,5 +34,5 @@ import IHP.ValidationSupport -- -- > setModal MyModalView { .. } -- -setModal :: (?context :: ControllerContext, ?request :: Request, View view) => view -> IO () +setModal :: (?context :: Request, ?request :: Request, View view) => view -> IO () setModal view = let ?view = view in Modal.setModal (ViewSupport.html view) diff --git a/ihp-ide/IHP/IDE/SchemaDesigner/Controller/Helper.hs b/ihp-ide/IHP/IDE/SchemaDesigner/Controller/Helper.hs index e026a0202..863bb21ca 100644 --- a/ihp-ide/IHP/IDE/SchemaDesigner/Controller/Helper.hs +++ b/ihp-ide/IHP/IDE/SchemaDesigner/Controller/Helper.hs @@ -25,7 +25,7 @@ instance ParamReader [IndexColumn] where Right result -> Right result readSchema :: - ( ?context::ControllerContext + ( ?context::Request , ?modelContext::ModelContext , ?theAction::controller , ?respond::Respond @@ -41,7 +41,7 @@ getSqlError = SchemaDesignerParser.parseSchemaSql >>= \case Right statements -> do pure Nothing updateSchema :: - ( ?context :: ControllerContext + ( ?context :: Request , ?modelContext::ModelContext , ?theAction::controller , ?respond::Respond diff --git a/ihp-ide/IHP/IDE/SchemaDesigner/View/Columns/NewForeignKey.hs b/ihp-ide/IHP/IDE/SchemaDesigner/View/Columns/NewForeignKey.hs index ba34381a0..e3649b4ac 100644 --- a/ihp-ide/IHP/IDE/SchemaDesigner/View/Columns/NewForeignKey.hs +++ b/ihp-ide/IHP/IDE/SchemaDesigner/View/Columns/NewForeignKey.hs @@ -36,7 +36,7 @@ instance View NewForeignKeyView where -- | Shared form modal for creating and editing foreign key constraints. foreignKeyFormModal - :: (?context :: ControllerContext, ?request :: Request) + :: (?context :: Request, ?request :: Request) => Text -- ^ Form action URL -> Text -- ^ Table name -> Text -- ^ Column name diff --git a/ihp-ide/IHP/IDE/SchemaDesigner/View/Policies/New.hs b/ihp-ide/IHP/IDE/SchemaDesigner/View/Policies/New.hs index 0c40d32e6..3287fe549 100644 --- a/ihp-ide/IHP/IDE/SchemaDesigner/View/Policies/New.hs +++ b/ihp-ide/IHP/IDE/SchemaDesigner/View/Policies/New.hs @@ -26,7 +26,7 @@ instance View NewPolicyView where modal = policyFormModal tableName columns policy (pathTo CreatePolicyAction) mempty "Create Policy" "New Policy" -- | Shared form modal for creating and editing policies. -policyFormModal :: (?context :: ControllerContext, ?request :: Request) => Text -> [Column] -> Statement -> Text -> Html -> Text -> Text -> Modal +policyFormModal :: (?context :: Request, ?request :: Request) => Text -> [Column] -> Statement -> Text -> Html -> Text -> Text -> Modal policyFormModal tableName columns policy formAction extraHiddenFields buttonText modalTitle = Modal { modalContent, modalFooter, modalCloseUrl, modalTitle } where modalContent = [hsx| diff --git a/ihp-ide/IHP/IDE/ToolServer/Layout.hs b/ihp-ide/IHP/IDE/ToolServer/Layout.hs index a7a2a386b..3e9762e0b 100644 --- a/ihp-ide/IHP/IDE/ToolServer/Layout.hs +++ b/ihp-ide/IHP/IDE/ToolServer/Layout.hs @@ -166,7 +166,7 @@ toolServerLayout inner = [hsx| target :: Maybe Text target = if isExternal then "_blank" else Nothing -appUrl :: (?context :: ControllerContext, ?request :: Request) => Text +appUrl :: (?context :: Request, ?request :: Request) => Text appUrl = let (AppUrl url) = lookupRequestVault appUrlVaultKey ?request in url -- | https://github.com/encharm/Font-Awesome-SVG-PNG/blob/master/white/svg/terminal.svg diff --git a/ihp-job-dashboard/IHP/Job/Dashboard.hs b/ihp-job-dashboard/IHP/Job/Dashboard.hs index 23722dbfb..d62a05bec 100644 --- a/ihp-job-dashboard/IHP/Job/Dashboard.hs +++ b/ihp-job-dashboard/IHP/Job/Dashboard.hs @@ -76,27 +76,27 @@ class ( job ~ GetModelByTableName (GetTableName job) -- | How this job's section should be displayed in the dashboard. By default it's displayed as a table, -- but this can be any arbitrary view! Make some cool graphs :) - makeDashboardSection :: (?context :: ControllerContext, ?modelContext :: ModelContext) => IO SomeView + makeDashboardSection :: (?context :: Request, ?modelContext :: ModelContext) => IO SomeView - makePageView :: (?context :: ControllerContext, ?modelContext :: ModelContext) => Int -> Int -> IO SomeView + makePageView :: (?context :: Request, ?modelContext :: ModelContext) => Int -> Int -> IO SomeView -- | The content of the page that will be displayed for a detail view of this job. -- By default, the ID, Status, Created/Updated at times, and last error are displayed. -- Can be defined as any arbitrary view. - makeDetailView :: (?context :: ControllerContext, ?modelContext :: ModelContext) => job -> IO SomeView + makeDetailView :: (?context :: Request, ?modelContext :: ModelContext) => job -> IO SomeView makeDetailView job = do pure $ SomeView $ HtmlView $ renderBaseJobDetailView (buildBaseJob job) -- | The content of the page that will be displayed for the "new job" form of this job. -- By default, only the submit button is rendered. For additonal form data, define your own implementation. -- Can be defined as any arbitrary view, but it should be a form. - makeNewJobView :: (?context :: ControllerContext, ?modelContext :: ModelContext) => IO SomeView + makeNewJobView :: (?context :: Request, ?modelContext :: ModelContext) => IO SomeView makeNewJobView = pure $ SomeView $ HtmlView $ renderNewBaseJobForm $ tableName @job -- | The action run to create and insert a new value of this job into the database. -- By default, create an empty record and insert it. -- To add more data, define your own implementation. - createNewJob :: (?context :: ControllerContext, ?modelContext :: ModelContext) => IO () + createNewJob :: (?context :: Request, ?modelContext :: ModelContext) => IO () createNewJob = do newRecord @job |> create pure () @@ -112,32 +112,32 @@ class ( job ~ GetModelByTableName (GetTableName job) -- so you'll get a compile error if you try and include a type that is not a job. class JobsDashboard (jobs :: [Type]) where -- | Creates the entire dashboard by recursing on the type list and calling 'makeDashboardSection' on each type. - makeDashboard :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?request :: Request) => IO SomeView + makeDashboard :: (?context :: Request, ?modelContext :: ModelContext, ?request :: Request) => IO SomeView includedJobTables :: [Text] -- | Renders the index page, which is the view returned from 'makeDashboard'. - indexPage :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => IO ResponseReceived + indexPage :: (?context :: Request, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => IO ResponseReceived - listJob :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Text -> IO ResponseReceived - listJob' :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Bool -> IO ResponseReceived + listJob :: (?context :: Request, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Text -> IO ResponseReceived + listJob' :: (?context :: Request, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => 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, ?respond :: Respond, ?request :: Request) => Text -> UUID -> IO ResponseReceived - viewJob' :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Bool -> IO ResponseReceived + viewJob :: (?context :: Request, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Text -> UUID -> IO ResponseReceived + viewJob' :: (?context :: Request, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => 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, ?respond :: Respond, ?request :: Request) => Text -> IO ResponseReceived - newJob' :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Bool -> IO ResponseReceived + newJob :: (?context :: Request, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Text -> IO ResponseReceived + newJob' :: (?context :: Request, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Bool -> IO ResponseReceived -- | Deletes a job from the database. - deleteJob :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Text -> UUID -> IO ResponseReceived - deleteJob' :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Bool -> IO ResponseReceived + deleteJob :: (?context :: Request, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Text -> UUID -> IO ResponseReceived + deleteJob' :: (?context :: Request, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Bool -> IO ResponseReceived - retryJob :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Text -> UUID -> IO ResponseReceived - retryJob' :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => IO ResponseReceived + retryJob :: (?context :: Request, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Text -> UUID -> IO ResponseReceived + retryJob' :: (?context :: Request, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => IO ResponseReceived -- If no types are passed, try to get all tables dynamically and render them as BaseJobs instance JobsDashboard '[] where @@ -375,7 +375,7 @@ getNotIncludedTableNames includedNames = sqlQueryHasql getHasqlPool (Snippet.sql "SELECT table_name::text FROM information_schema.tables WHERE table_name LIKE '%_jobs' AND NOT (table_name = ANY(" <> Snippet.param includedNames <> Snippet.sql "))") (Decoders.rowList (Decoders.column (Decoders.nonNullable Decoders.text))) -buildBaseJobTable :: (?modelContext :: ModelContext, ?context :: ControllerContext, ?request :: Request) => Text -> IO SomeView +buildBaseJobTable :: (?modelContext :: ModelContext, ?context :: Request, ?request :: Request) => Text -> IO SomeView buildBaseJobTable tableName = do baseJobs <- sqlQueryHasql getHasqlPool (Snippet.sql "SELECT " <> Snippet.param tableName <> Snippet.sql ", id, status, updated_at, created_at, last_error FROM " diff --git a/ihp-job-dashboard/IHP/Job/Dashboard/Auth.hs b/ihp-job-dashboard/IHP/Job/Dashboard/Auth.hs index 815ae0e61..0fbffc738 100644 --- a/ihp-job-dashboard/IHP/Job/Dashboard/Auth.hs +++ b/ihp-job-dashboard/IHP/Job/Dashboard/Auth.hs @@ -24,7 +24,7 @@ import qualified IHP.EnvVar as EnvVar -- -- Define your own implementation to use custom authentication for production. class AuthenticationMethod a where - authenticate :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?request :: Request, ?respond :: Respond) => IO () + authenticate :: (?context :: Request, ?modelContext :: ModelContext, ?request :: Request, ?respond :: Respond) => IO () -- | Don't use any authentication for jobs. data NoAuth diff --git a/ihp-job-dashboard/IHP/Job/Dashboard/Types.hs b/ihp-job-dashboard/IHP/Job/Dashboard/Types.hs index 4a32477ba..60ccb2ebd 100644 --- a/ihp-job-dashboard/IHP/Job/Dashboard/Types.hs +++ b/ihp-job-dashboard/IHP/Job/Dashboard/Types.hs @@ -37,10 +37,10 @@ class TableViewable a where newJobLink :: Html -- | Gets records for displaying in the dashboard index page - getIndex :: (?context :: ControllerContext, ?modelContext :: ModelContext) => IO [a] + getIndex :: (?context :: Request, ?modelContext :: ModelContext) => IO [a] -- | Gets paginated records for displaying in the list page - getPage :: (?context :: ControllerContext, ?modelContext :: ModelContext) => Int -> Int -> IO [a] + getPage :: (?context :: Request, ?modelContext :: ModelContext) => Int -> Int -> IO [a] -- | Often, jobs are related to some model type. These relations are modeled through the type system. diff --git a/ihp-job-dashboard/IHP/Job/Dashboard/View.hs b/ihp-job-dashboard/IHP/Job/Dashboard/View.hs index 0ba8ffd6a..1db23e0a7 100644 --- a/ihp-job-dashboard/IHP/Job/Dashboard/View.hs +++ b/ihp-job-dashboard/IHP/Job/Dashboard/View.hs @@ -8,7 +8,7 @@ Description: Views for Job dashboard module IHP.Job.Dashboard.View where import IHP.Prelude -import IHP.ViewPrelude (JobStatus(..), ControllerContext, Html, View, hsx, html, timeAgo) +import IHP.ViewPrelude (JobStatus(..), Request, Html, View, hsx, html, timeAgo) import qualified Data.List as List import IHP.Job.Dashboard.Types import IHP.Job.Dashboard.Utils @@ -197,7 +197,7 @@ renderBaseJobDetailView job = let table = job.table in [hsx| -- TABLE VIEWABLE view helpers ----------------------------------- makeDashboardSectionFromTableViewable :: forall a. (TableViewable a - , ?context :: ControllerContext + , ?context :: Request , ?modelContext :: ModelContext) => IO SomeView makeDashboardSectionFromTableViewable = do indexRows <- getIndex @a @@ -235,7 +235,7 @@ renderTableViewableTable rows = let -makeListPageFromTableViewable :: forall a. (TableViewable a, ?context :: ControllerContext, ?modelContext :: ModelContext) => Int -> Int -> IO SomeView +makeListPageFromTableViewable :: forall a. (TableViewable a, ?context :: Request, ?modelContext :: ModelContext) => Int -> Int -> IO SomeView makeListPageFromTableViewable page pageSize = do pageData <- getPage @a (page - 1) pageSize numPages <- numberOfPagesForTable (modelTableName @a) pageSize diff --git a/ihp-sitemap/IHP/SEO/Sitemap/ControllerFunctions.hs b/ihp-sitemap/IHP/SEO/Sitemap/ControllerFunctions.hs index 99626b38f..a30a47033 100644 --- a/ihp-sitemap/IHP/SEO/Sitemap/ControllerFunctions.hs +++ b/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, ?request :: Request, ?respond :: Respond) => Sitemap -> IO ResponseReceived +renderXmlSitemap :: (?context :: Request, ?request :: Request, ?respond :: Respond) => Sitemap -> IO ResponseReceived renderXmlSitemap Sitemap { links } = do let sitemap = Markup.toMarkup [xmlDocument, sitemapLinks] renderXml $ Markup.renderMarkup sitemap diff --git a/ihp-ssc/IHP/ServerSideComponent/ControllerFunctions.hs b/ihp-ssc/IHP/ServerSideComponent/ControllerFunctions.hs index 1d0e4100d..a6b60f3e8 100644 --- a/ihp-ssc/IHP/ServerSideComponent/ControllerFunctions.hs +++ b/ihp-ssc/IHP/ServerSideComponent/ControllerFunctions.hs @@ -26,7 +26,7 @@ $(Aeson.deriveJSON Aeson.defaultOptions { sumEncoding = defaultTaggedObject { ta $(Aeson.deriveJSON Aeson.defaultOptions { sumEncoding = defaultTaggedObject { tagFieldName = "type" }} ''NodeOperation) $(Aeson.deriveJSON Aeson.defaultOptions { sumEncoding = defaultTaggedObject { tagFieldName = "type" }} ''SSCError) -setState :: (?instanceRef :: IORef (ComponentInstance state), ?connection :: WebSocket.Connection, Component state action, ?context :: ControllerContext, ?request :: Request) => state -> IO () +setState :: (?instanceRef :: IORef (ComponentInstance state), ?connection :: WebSocket.Connection, Component state action, ?context :: Request, ?request :: Request) => state -> IO () setState state = do oldState <- (.state) <$> readIORef ?instanceRef let oldHtml = oldState diff --git a/ihp-ssc/IHP/ServerSideComponent/Types.hs b/ihp-ssc/IHP/ServerSideComponent/Types.hs index 2d4d4f765..0a2547a1e 100644 --- a/ihp-ssc/IHP/ServerSideComponent/Types.hs +++ b/ihp-ssc/IHP/ServerSideComponent/Types.hs @@ -15,14 +15,14 @@ class Component state action | state -> action where action :: ( ?instanceRef :: IORef (ComponentInstance state) , ?connection :: WebSocket.Connection - , ?context :: ControllerContext + , ?context :: Request , ?modelContext :: ModelContext ) => state -> action -> IO state componentDidMount :: ( ?instanceRef :: IORef (ComponentInstance state) , ?connection :: WebSocket.Connection - , ?context :: ControllerContext + , ?context :: Request , ?modelContext :: ModelContext ) => state -> IO state componentDidMount state = pure state diff --git a/ihp/IHP/AuthSupport/Controller/Sessions.hs b/ihp/IHP/AuthSupport/Controller/Sessions.hs index fb56b8f75..4a028223e 100644 --- a/ihp/IHP/AuthSupport/Controller/Sessions.hs +++ b/ihp/IHP/AuthSupport/Controller/Sessions.hs @@ -25,7 +25,7 @@ import IHP.Hasql.FromRow (FromRowHasql) -- In case the user is already logged in, redirects to the home page ('afterLoginRedirectPath'). newSessionAction :: forall record action. ( ?theAction :: action - , ?context :: ControllerContext + , ?context :: Request , ?request :: Request , ?respond :: Respond , HasNewSessionUrl record @@ -54,7 +54,7 @@ newSessionAction = do -- After a successful login, the user is redirect to 'afterLoginRedirectPath'. createSessionAction :: forall record action. (?theAction :: action - , ?context :: ControllerContext + , ?context :: Request , ?request :: Request , ?respond :: Respond , ?modelContext :: ModelContext @@ -110,7 +110,7 @@ createSessionAction = do -- | Logs out the user and redirects to `afterLogoutRedirectPath` or login page by default deleteSessionAction :: forall record action. ( ?theAction :: action - , ?context :: ControllerContext + , ?context :: Request , ?request :: Request , ?respond :: Respond , ?modelContext :: ModelContext @@ -172,13 +172,13 @@ class ( Typeable record -- > unless (user.isConfirmed) do -- > setErrorMessage "Please click the confirmation link we sent to your email before you can use the App" -- > redirectTo NewSessionAction - beforeLogin :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?request :: Request) => record -> IO () + beforeLogin :: (?context :: Request, ?modelContext :: ModelContext, ?request :: Request) => record -> IO () beforeLogin _ = pure () -- | Callback that is executed just before the user is logged out -- -- This is called only if user session exists - beforeLogout :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?request :: Request) => record -> IO () + beforeLogout :: (?context :: Request, ?modelContext :: ModelContext, ?request :: Request) => record -> IO () beforeLogout _ = pure () -- | Return's the @query\ \@User@ used by the controller. Customize this to e.g. exclude guest users from logging in. diff --git a/ihp/IHP/AutoRefresh.hs b/ihp/IHP/AutoRefresh.hs index c64c016f7..10531509b 100644 --- a/ihp/IHP/AutoRefresh.hs +++ b/ihp/IHP/AutoRefresh.hs @@ -50,7 +50,7 @@ autoRefresh :: ( ?theAction :: action , Controller action , ?modelContext :: ModelContext - , ?context :: ControllerContext + , ?context :: Request , ?request :: Request , ?respond :: Respond ) => ((?modelContext :: ModelContext, ?respond :: Respond) => IO ResponseReceived) -> IO ResponseReceived @@ -186,7 +186,7 @@ captureResponseBody originalRespond action = do captured <- readIORef bodyRef pure (result, captured) -registerNotificationTrigger :: (?modelContext :: ModelContext, ?context :: ControllerContext) => IORef (Set Text) -> IORef AutoRefreshServer -> IO () +registerNotificationTrigger :: (?modelContext :: ModelContext, ?context :: Request) => IORef (Set Text) -> IORef AutoRefreshServer -> IO () registerNotificationTrigger touchedTablesVar autoRefreshServer = do touchedTables <- Set.toList <$> readIORef touchedTablesVar subscribedTables <- (.subscribedTables) <$> (autoRefreshServer |> readIORef) diff --git a/ihp/IHP/AutoRefresh/View.hs b/ihp/IHP/AutoRefresh/View.hs index 5fbae84f3..5acb18531 100644 --- a/ihp/IHP/AutoRefresh/View.hs +++ b/ihp/IHP/AutoRefresh/View.hs @@ -4,12 +4,11 @@ import IHP.Prelude import IHP.AutoRefresh.Types import IHP.HSX.MarkupQQ (hsx) import IHP.HSX.Markup (Html) -import IHP.Controller.Context import IHP.AutoRefresh (autoRefreshStateVaultKey) import qualified Data.Vault.Lazy as Vault -import Network.Wai (vault) +import Network.Wai (Request, vault) -autoRefreshMeta :: (?context :: ControllerContext) => Html +autoRefreshMeta :: (?context :: Request) => Html autoRefreshMeta = case Vault.lookup autoRefreshStateVaultKey ?context.vault of Just (AutoRefreshEnabled { sessionId }) -> [hsx||] diff --git a/ihp/IHP/Controller/Context.hs b/ihp/IHP/Controller/Context.hs deleted file mode 100644 index 2f51a22d7..000000000 --- a/ihp/IHP/Controller/Context.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-| -Module: IHP.Controller.Context -Copyright: (c) digitally induced GmbH, 2020 - -@'ControllerContext'@ is a type alias for the WAI 'Request' — all -request-scoped state lives in @request.vault@ (see 'IHP.RequestVault'). -The alias is preserved so existing code that uses the @?context@ implicit -parameter keeps working; 'HasField' instances for @frameworkConfig@ and -@logger@ come from 'IHP.RequestVault'. --} -module IHP.Controller.Context - ( ControllerContext - , newControllerContext - , ActionType(..) - ) where - -import Prelude -import Network.Wai (Request) -import IHP.ActionType (ActionType(..)) -import IHP.RequestVault () -- for HasField "frameworkConfig"/"logger"/"pgListener" on Request - --- | The WAI 'Request' threaded through controllers and views. -type ControllerContext = Request - --- | Returns the current request. Kept for source compatibility with callers --- that previously wrapped the request in a @ControllerContext@. -newControllerContext :: (?request :: Request) => IO ControllerContext -newControllerContext = pure ?request -{-# INLINE newControllerContext #-} diff --git a/ihp/IHP/Controller/FileUpload.hs b/ihp/IHP/Controller/FileUpload.hs index 162872b55..660a40adb 100644 --- a/ihp/IHP/Controller/FileUpload.hs +++ b/ihp/IHP/Controller/FileUpload.hs @@ -19,7 +19,7 @@ import Network.Wai (Request) import qualified IHP.ModelSupport as ModelSupport import qualified Data.ByteString.Lazy as LBS import Wai.Request.Params.Middleware (RequestBody (..)) -import IHP.Controller.Context () +import IHP.RequestVault () -- HasField "parsedBody" Request RequestBody import qualified System.Process as Process -- | Returns a file upload from the request as a ByteString. diff --git a/ihp/IHP/Controller/Layout.hs b/ihp/IHP/Controller/Layout.hs index a43052451..8bebf35b6 100644 --- a/ihp/IHP/Controller/Layout.hs +++ b/ihp/IHP/Controller/Layout.hs @@ -12,14 +12,13 @@ module IHP.Controller.Layout import Prelude import IHP.ViewSupport -import IHP.Controller.Context import Network.Wai (Request, Middleware, vault) import System.IO.Unsafe (unsafePerformIO) import qualified Data.Vault.Lazy as Vault import Data.IORef -- | Wrapper for a layout function that will be applied to views -newtype ViewLayout = ViewLayout ((?context :: ControllerContext, ?request :: Request) => Layout) +newtype ViewLayout = ViewLayout ((?context :: Request, ?request :: Request) => Layout) -- | Vault key for storing the mutable layout IORef in each request viewLayoutVaultKey :: Vault.Key (IORef ViewLayout) @@ -43,7 +42,7 @@ viewLayoutMiddleware app request respond = do -- > initContext = do -- > setLayout defaultLayout -- -setLayout :: (?context :: ControllerContext, ?request :: Request) => ((?context :: ControllerContext, ?request :: Request) => Layout) -> IO () +setLayout :: (?context :: Request, ?request :: Request) => ((?context :: Request, ?request :: Request) => Layout) -> IO () setLayout layout = case Vault.lookup viewLayoutVaultKey (vault ?request) of Just ref -> writeIORef ref (ViewLayout layout) diff --git a/ihp/IHP/Controller/Render.hs b/ihp/IHP/Controller/Render.hs index 0d04ceb83..9da7664a7 100644 --- a/ihp/IHP/Controller/Render.hs +++ b/ihp/IHP/Controller/Render.hs @@ -30,7 +30,7 @@ respondSvg (Markup builder) = respondWith $ responseBuilder status200 [(hContentType, "image/svg+xml"), (hConnection, "keep-alive")] builder {-# INLINABLE respondSvg #-} -renderHtml :: forall view. (ViewSupport.View view, ?context :: ControllerContext, ?request :: Request) => view -> IO Markup +renderHtml :: forall view. (ViewSupport.View view, ?context :: Request, ?request :: Request) => view -> IO Markup renderHtml !view = do let ?view = view ViewSupport.beforeRender view @@ -60,7 +60,7 @@ renderJson' additionalHeaders json = respondWith $ responseLBS status200 ([(hCon {-# INLINE renderJson' #-} {-# INLINE render #-} -render :: forall view. (ViewSupport.View view, ?context :: ControllerContext, ?request :: Request, ?respond :: Respond) => view -> IO ResponseReceived +render :: forall view. (ViewSupport.View view, ?context :: Request, ?request :: Request, ?respond :: Respond) => view -> IO ResponseReceived render !view = do let !currentRequest = ?request renderHtmlView currentRequest view @@ -68,7 +68,7 @@ render !view = do -- | Renders HTML or JSON based on the request's Accept header. -- Requires both 'View' and 'JsonView' instances for the view type. {-# INLINE renderHtmlOrJson #-} -renderHtmlOrJson :: forall view. (ViewSupport.View view, ViewSupport.JsonView view, ?context :: ControllerContext, ?request :: Request, ?respond :: Respond) => view -> IO ResponseReceived +renderHtmlOrJson :: forall view. (ViewSupport.View view, ViewSupport.JsonView view, ?context :: Request, ?request :: Request, ?respond :: Respond) => view -> IO ResponseReceived renderHtmlOrJson !view = do let !currentRequest = ?request let acceptHeader = lookup hAccept (?request.requestHeaders) @@ -84,7 +84,7 @@ renderHtmlOrJson !view = do ] fromMaybe send406Error (Accept.mapAcceptMedia formats accept) -renderHtmlView :: (ViewSupport.View view, ?context :: ControllerContext, ?respond :: Respond) => Request -> view -> IO ResponseReceived +renderHtmlView :: (ViewSupport.View view, ?context :: Request, ?respond :: Respond) => Request -> view -> IO ResponseReceived renderHtmlView currentRequest view = do let next request respond = do let ?request = request diff --git a/ihp/IHP/ControllerPrelude.hs b/ihp/IHP/ControllerPrelude.hs index a72c8dc2d..d1b2596ce 100644 --- a/ihp/IHP/ControllerPrelude.hs +++ b/ihp/IHP/ControllerPrelude.hs @@ -24,7 +24,6 @@ module IHP.ControllerPrelude , module IHP.ValidationSupport , module IHP.AutoRefresh , module IHP.FlashMessages - , module IHP.Controller.Context , module IHP.Modal.Types , setModal , module IHP.Controller.Layout @@ -64,7 +63,6 @@ import IHP.RouterSupport hiding (get, post) import IHP.Controller.Redirect import Database.PostgreSQL.Simple.Types (Only (..)) import IHP.FlashMessages -import IHP.Controller.Context import IHP.Controller.Layout import IHP.Modal.Types @@ -91,5 +89,5 @@ import IHP.HSX.MarkupQQ (hsx, uncheckedHsx, customHsx) -- -- > setModal MyModalView { .. } -- -setModal :: (?context :: ControllerContext, ?request :: Request, View view) => view -> IO () +setModal :: (?context :: Request, ?request :: Request, View view) => view -> IO () setModal view = let ?view = view in Modal.setModal (ViewSupport.html view) diff --git a/ihp/IHP/ControllerSupport.hs b/ihp/IHP/ControllerSupport.hs index 936e24516..e2671514f 100644 --- a/ihp/IHP/ControllerSupport.hs +++ b/ihp/IHP/ControllerSupport.hs @@ -12,7 +12,7 @@ module IHP.ControllerSupport , getFiles , Controller (..) , runAction -, Context.ControllerContext +, ControllerContext , InitControllerContext (..) , runActionWithNewContext , newContextForAction @@ -51,8 +51,8 @@ import Wai.Request.Params.Middleware (Respond) import qualified Data.CaseInsensitive import qualified Data.Typeable as Typeable import IHP.FrameworkConfig.Types (FrameworkConfig (..), ConfigProvider) -import qualified IHP.Controller.Context as Context import IHP.Controller.Response +import IHP.RequestVault () -- for HasField "frameworkConfig"/"logger"/"pgListener" on Request import Network.Wai.Middleware.EarlyReturn (earlyReturnMiddleware) import Network.HTTP.Types.Header import qualified Data.Aeson as Aeson @@ -71,14 +71,21 @@ import System.IO.Unsafe (unsafePerformIO) type Action' = IO ResponseReceived +-- | The WAI 'Request' threaded through controllers and views as the +-- @?context@ implicit parameter. All request-scoped state lives in +-- @request.vault@ (see 'IHP.RequestVault'). The type alias is preserved +-- for source compatibility with existing @?context :: ControllerContext@ +-- type signatures. +type ControllerContext = Request + class (Show controller, Eq controller) => Controller controller where - beforeAction :: (?context :: Context.ControllerContext, ?modelContext :: ModelContext, ?theAction :: controller, ?respond :: Respond, ?request :: Request) => IO () + beforeAction :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?theAction :: controller, ?respond :: Respond, ?request :: Request) => IO () beforeAction = pure () {-# INLINABLE beforeAction #-} - action :: (?context :: Context.ControllerContext, ?modelContext :: ModelContext, ?theAction :: controller, ?respond :: Respond, ?request :: Request) => controller -> IO ResponseReceived + action :: (?context :: ControllerContext, ?modelContext :: ModelContext, ?theAction :: controller, ?respond :: Respond, ?request :: Request) => controller -> IO ResponseReceived class InitControllerContext application where - initContext :: (?modelContext :: ModelContext, ?request :: Request, ?respond :: Respond, ?context :: Context.ControllerContext) => IO () + initContext :: (?modelContext :: ModelContext, ?request :: Request, ?respond :: Respond, ?context :: ControllerContext) => IO () initContext = pure () {-# INLINABLE initContext #-} @@ -86,7 +93,7 @@ instance InitControllerContext () where initContext = pure () {-# INLINE runAction #-} -runAction :: forall controller. (Controller controller, ?context :: Context.ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond) => controller -> IO ResponseReceived +runAction :: forall controller. (Controller controller, ?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond) => controller -> IO ResponseReceived runAction controller = do let ?theAction = controller let ?request = ?context @@ -109,11 +116,10 @@ newContextForAction , Typeable application , Typeable controller ) - => controller -> IO Context.ControllerContext + => controller -> IO ControllerContext newContextForAction controller = do let ?modelContext = ?request.modelContext - controllerContext <- Context.newControllerContext - let ?context = controllerContext + let ?context = ?request wrapInitContextException (initContext @application) pure ?context @@ -131,14 +137,13 @@ setupActionContext , Typeable application ) => Typeable.TypeRep -> Request -> Respond - -> IO Context.ControllerContext + -> IO ControllerContext setupActionContext controllerTypeRep waiRequest waiRespond = do let !request' = waiRequest { vault = Vault.insert actionTypeVaultKey (ActionType controllerTypeRep) waiRequest.vault } let ?request = request' let ?respond = waiRespond let ?modelContext = request'.modelContext - controllerContext <- Context.newControllerContext - let ?context = controllerContext + let ?context = ?request wrapInitContextException (initContext @application) pure ?context @@ -189,8 +194,7 @@ startWebSocketApp initialState onHTTP waiRequest waiRespond = do let handleConnection pendingConnection = do connection <- WebSockets.acceptRequest pendingConnection - controllerContext <- Context.newControllerContext - let ?context = controllerContext + let ?context = ?request try (initContext @application) >>= \case Left (exception :: SomeException) -> putStrLn $ "Unexpected exception in initContext, " <> show exception @@ -247,7 +251,7 @@ rewriteWebSocketFallbackStatus (WaiInternal.ResponseRaw handler fallback) = rewriteWebSocketFallbackStatus other = other -jumpToAction :: forall action. (Controller action, ?context :: Context.ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => action -> IO ResponseReceived +jumpToAction :: forall action. (Controller action, ?context :: ControllerContext, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => action -> IO ResponseReceived jumpToAction theAction = do let ?theAction = theAction beforeAction @action diff --git a/ihp/IHP/ErrorController.hs b/ihp/IHP/ErrorController.hs index 99454b347..132790362 100644 --- a/ihp/IHP/ErrorController.hs +++ b/ihp/IHP/ErrorController.hs @@ -38,12 +38,11 @@ import IHP.HSX.MarkupQQ (hsx) import qualified IHP.ModelSupport as ModelSupport import IHP.FrameworkConfig import qualified IHP.Environment as Environment -import IHP.Controller.Context import IHP.Controller.NotFound (handleNotFound, buildNotFoundResponse) import qualified IHP.Log as Log import IHP.Log (writeLog) import IHP.Log.Types (LogLevel(..)) -import IHP.ActionType (actionTypeVaultKey) +import IHP.ActionType (actionTypeVaultKey, ActionType(..)) import qualified Data.Vault.Lazy as Vault tshow :: Show a => a -> Text @@ -65,7 +64,7 @@ newtype InitContextException = InitContextException SomeException instance Exception.Exception InitContextException -displayException :: (Show action, ?context :: ControllerContext, ?request :: Request, ?respond :: Respond) => SomeException -> action -> Text -> IO ResponseReceived +displayException :: (Show action, ?context :: Request, ?request :: Request, ?respond :: Respond) => SomeException -> action -> Text -> IO ResponseReceived displayException exception action additionalInfo = do -- Dev handlers display helpful tips on how to resolve the problem let devHandlers = @@ -105,7 +104,7 @@ displayException exception action additionalInfo = do -- -- In dev mode the action and exception is added to the output. -- In production mode nothing is specific is communicated about the exception -genericHandler :: (Show controller, ?context :: ControllerContext, ?respond :: Respond) => Exception.SomeException -> controller -> Text -> IO ResponseReceived +genericHandler :: (Show controller, ?context :: Request, ?respond :: Respond) => Exception.SomeException -> controller -> Text -> IO ResponseReceived genericHandler exception controller additionalInfo = do let errorMessageText = "An exception was raised while running the action " <> tshow controller <> additionalInfo let errorMessageTitle = Exception.displayException exception @@ -124,7 +123,7 @@ genericHandler exception controller additionalInfo = do ?respond $ responseBuilder status500 [(hContentType, "text/html")] ((renderError ?context.frameworkConfig.environment errorTitle errorMessage) |> getBuilder) -postgresHandler :: (Show controller, ?context :: ControllerContext, ?respond :: Respond) => SomeException -> controller -> Text -> Maybe (IO ResponseReceived) +postgresHandler :: (Show controller, ?context :: Request, ?respond :: Respond) => SomeException -> controller -> Text -> Maybe (IO ResponseReceived) postgresHandler exception controller additionalInfo = do let handlePostgresOutdatedError :: Text -> Markup -> IO ResponseReceived @@ -215,7 +214,7 @@ postgresHandler exception controller additionalInfo = do ?respond $ responseBuilder status500 [(hContentType, "text/html")] ((renderError Environment.Development title errorMessage) |> getBuilder) Nothing -> Nothing -patternMatchFailureHandler :: (Show controller, ?context :: ControllerContext, ?respond :: Respond) => SomeException -> controller -> Text -> Maybe (IO ResponseReceived) +patternMatchFailureHandler :: (Show controller, ?context :: Request, ?respond :: Respond) => SomeException -> controller -> Text -> Maybe (IO ResponseReceived) patternMatchFailureHandler exception controller additionalInfo = do case fromException exception of Just (exception :: Exception.PatternMatchFail) -> Just do @@ -239,7 +238,7 @@ patternMatchFailureHandler exception controller additionalInfo = do -- Handler for 'IHP.Controller.Param.ParamNotFoundException' -- Only used in dev mode of the app. -paramNotFoundExceptionHandler :: (Show controller, ?context :: ControllerContext, ?request :: Request, ?respond :: Respond) => SomeException -> controller -> Text -> Maybe (IO ResponseReceived) +paramNotFoundExceptionHandler :: (Show controller, ?context :: Request, ?request :: Request, ?respond :: Respond) => SomeException -> controller -> Text -> Maybe (IO ResponseReceived) paramNotFoundExceptionHandler exception controller additionalInfo = do case fromException exception of Just (exception@(Param.ParamNotFoundException paramName)) -> Just do @@ -304,7 +303,7 @@ paramNotFoundExceptionHandler exception controller additionalInfo = do -- Handler for 'IHP.ModelSupport.RecordNotFoundException' -- -- Used only in development mode of the app. -recordNotFoundExceptionHandlerDev :: (Show controller, ?context :: ControllerContext, ?respond :: Respond) => SomeException -> controller -> Text -> Maybe (IO ResponseReceived) +recordNotFoundExceptionHandlerDev :: (Show controller, ?context :: Request, ?respond :: Respond) => SomeException -> controller -> Text -> Maybe (IO ResponseReceived) recordNotFoundExceptionHandlerDev exception controller additionalInfo = case fromException exception of Just (exception@(ModelSupport.RecordNotFoundException { queryAndParams })) -> Just do @@ -344,7 +343,7 @@ recordNotFoundExceptionHandlerDev exception controller additionalInfo = -- Handler for 'IHP.ModelSupport.RecordNotFoundException' -- -- Used only in production mode of the app. The exception is handled by calling 'handleNotFound' -recordNotFoundExceptionHandlerProd :: (?context :: ControllerContext, ?request :: Request, ?respond :: Respond) => SomeException -> controller -> Text -> Maybe (IO ResponseReceived) +recordNotFoundExceptionHandlerProd :: (?context :: Request, ?request :: Request, ?respond :: Respond) => SomeException -> controller -> Text -> Maybe (IO ResponseReceived) recordNotFoundExceptionHandlerProd exception controller additionalInfo = case fromException exception of Just (exception@(ModelSupport.RecordNotFoundException {})) -> diff --git a/ihp/IHP/FileStorage/ControllerFunctions.hs b/ihp/IHP/FileStorage/ControllerFunctions.hs index 251c91f9e..ac1f56993 100644 --- a/ihp/IHP/FileStorage/ControllerFunctions.hs +++ b/ihp/IHP/FileStorage/ControllerFunctions.hs @@ -22,7 +22,6 @@ module IHP.FileStorage.ControllerFunctions import IHP.Prelude import IHP.FileStorage.Types -import IHP.Controller.Context import IHP.Controller.FileUpload import IHP.FrameworkConfig import qualified IHP.ModelSupport as ModelSupport @@ -340,7 +339,7 @@ contentDispositionAttachmentAndFileName fileInfo = -- > redirectTo EditCompanyAction { .. } -- uploadToStorageWithOptions :: forall (fieldName :: Symbol) record (tableName :: Symbol). ( - ?context :: ControllerContext + ?context :: Request , ?request :: Request , SetField fieldName record (Maybe Text) , KnownSymbol fieldName @@ -390,7 +389,7 @@ uploadToStorageWithOptions options field record = do -- > redirectTo EditCompanyAction { .. } -- uploadToStorage :: forall (fieldName :: Symbol) record (tableName :: Symbol). ( - ?context :: ControllerContext + ?context :: Request , ?request :: Request , SetField fieldName record (Maybe Text) , KnownSymbol fieldName @@ -434,7 +433,7 @@ storage = ?context.frameworkConfig.appConfig |> fromMaybe (error "Could not find FileStorage in config. Did you call initS3Storage from your Config.hs?") -- | Returns the prefix for the storage. This is either @static/@ or an empty string depending on the storage. -storagePrefix :: (?context :: ControllerContext) => Text +storagePrefix :: (?context :: Request) => Text storagePrefix = case storage of StaticDirStorage { directory } -> directory S3Storage { baseUrl} -> baseUrl diff --git a/ihp/IHP/LoginSupport/Helper/Controller.hs b/ihp/IHP/LoginSupport/Helper/Controller.hs index 527fcf8f2..ad30fdc66 100644 --- a/ihp/IHP/LoginSupport/Helper/Controller.hs +++ b/ihp/IHP/LoginSupport/Helper/Controller.hs @@ -44,17 +44,17 @@ currentUserOrNothing = lookupAuthVault currentUserVaultKey ?request {-# INLINE currentUserOrNothing #-} -- | Returns the current user. Redirects to login if not logged in. -currentUser :: forall user. (?context :: ControllerContext, ?request :: Request, ?respond :: Respond, HasNewSessionUrl user, Typeable user, user ~ CurrentUserRecord) => user +currentUser :: forall user. (?context :: Request, ?request :: Request, ?respond :: Respond, HasNewSessionUrl user, Typeable user, user ~ CurrentUserRecord) => user currentUser = fromMaybe (redirectToLogin (newSessionUrl (Proxy @user))) currentUserOrNothing {-# INLINABLE currentUser #-} -- | Returns the ID of the current user. Redirects to login if not logged in. -currentUserId :: forall user userId. (?context :: ControllerContext, ?request :: Request, ?respond :: Respond, HasNewSessionUrl user, HasField "id" user userId, Typeable user, user ~ CurrentUserRecord) => userId +currentUserId :: forall user userId. (?context :: Request, ?request :: Request, ?respond :: Respond, HasNewSessionUrl user, HasField "id" user userId, Typeable user, user ~ CurrentUserRecord) => userId currentUserId = (currentUser @user).id {-# INLINABLE currentUserId #-} -- | Ensures that a user is logged in. Redirects to login page if not. -ensureIsUser :: forall user. (?context :: ControllerContext, ?request :: Request, ?respond :: Respond, HasNewSessionUrl user, Typeable user, user ~ CurrentUserRecord) => IO () +ensureIsUser :: forall user. (?context :: Request, ?request :: Request, ?respond :: Respond, HasNewSessionUrl user, Typeable user, user ~ CurrentUserRecord) => IO () ensureIsUser = case currentUserOrNothing @user of Just _ -> pure () @@ -80,12 +80,12 @@ currentAdminOrNothing = lookupAuthVault currentAdminVaultKey ?request {-# INLINE currentAdminOrNothing #-} -- | Returns the current admin. Redirects to login if not logged in. -currentAdmin :: forall admin. (?context :: ControllerContext, ?request :: Request, ?respond :: Respond, HasNewSessionUrl admin, Typeable admin, admin ~ CurrentAdminRecord) => admin +currentAdmin :: forall admin. (?context :: Request, ?request :: Request, ?respond :: Respond, HasNewSessionUrl admin, Typeable admin, admin ~ CurrentAdminRecord) => admin currentAdmin = fromMaybe (redirectToLogin (newSessionUrl (Proxy @admin))) currentAdminOrNothing {-# INLINABLE currentAdmin #-} -- | Returns the ID of the current admin. Redirects to login if not logged in. -currentAdminId :: forall admin adminId. (?context :: ControllerContext, ?request :: Request, ?respond :: Respond, HasNewSessionUrl admin, HasField "id" admin adminId, Typeable admin, admin ~ CurrentAdminRecord) => adminId +currentAdminId :: forall admin adminId. (?context :: Request, ?request :: Request, ?respond :: Respond, HasNewSessionUrl admin, HasField "id" admin adminId, Typeable admin, admin ~ CurrentAdminRecord) => adminId currentAdminId = (currentAdmin @admin).id {-# INLINABLE currentAdminId #-} @@ -97,7 +97,7 @@ currentAdminIdOrNothing = ModelSupport.Id <$> lookupAuthVault currentAdminIdVaul {-# INLINE currentAdminIdOrNothing #-} -- | Ensures that an admin is logged in. Redirects to login page if not. -ensureIsAdmin :: forall (admin :: Type). (?context :: ControllerContext, ?request :: Request, ?respond :: Respond, HasNewSessionUrl admin, Typeable admin, admin ~ CurrentAdminRecord) => IO () +ensureIsAdmin :: forall (admin :: Type). (?context :: Request, ?request :: Request, ?respond :: Respond, HasNewSessionUrl admin, Typeable admin, admin ~ CurrentAdminRecord) => IO () ensureIsAdmin = case currentAdminOrNothing @admin of Just _ -> pure () @@ -175,7 +175,7 @@ redirectToLogin newSessionPath = unsafePerformIO $ do -- > projects <- query @Project |> fetch -- enableRowLevelSecurityIfLoggedIn :: - ( ?context :: ControllerContext + ( ?context :: Request , ?request :: Request , ModelSupport.PrimaryKey (ModelSupport.GetTableName CurrentUserRecord) ~ UUID ) => IO () diff --git a/ihp/IHP/Pagination/ControllerFunctions.hs b/ihp/IHP/Pagination/ControllerFunctions.hs index be6134241..186706143 100644 --- a/ihp/IHP/Pagination/ControllerFunctions.hs +++ b/ihp/IHP/Pagination/ControllerFunctions.hs @@ -13,7 +13,6 @@ module IHP.Pagination.ControllerFunctions ) where import IHP.Prelude -import IHP.Controller.Context import IHP.Controller.Param ( paramOrDefault, paramOrNothing ) import IHP.Pagination.Types ( Options(..), Pagination(..) ) import IHP.QueryBuilder ( QueryBuilder, filterWhereILike, limit, offset ) @@ -50,7 +49,7 @@ import Data.Text.Encoding (encodeUtf8) -- > user <- userQ |> fetch -- > render IndexView { .. } paginate :: forall controller table . - (?context::ControllerContext + (?context::Request , ?modelContext :: ModelContext , ?theAction :: controller , ?request :: Request @@ -81,7 +80,7 @@ paginate = paginateWithOptions defaultPaginationOptions -- > user <- userQ |> fetch -- > render IndexView { .. } paginateWithOptions :: forall controller table . - (?context::ControllerContext + (?context::Request , ?modelContext :: ModelContext , ?theAction :: controller , ?request :: Request @@ -124,7 +123,7 @@ paginateWithOptions options query = do -- > user <- userQ |> fetch -- > render IndexView { .. } filterList :: forall name table model . - (?context::ControllerContext + (?context::Request , ?request :: Request , KnownSymbol name , HasField name model Text @@ -179,7 +178,7 @@ defaultPaginationOptions = paginatedSqlQuery :: ( FromRowHasql model , ToSnippetParams parameters - , ?context :: ControllerContext + , ?context :: Request , ?modelContext :: ModelContext , ?request :: Request ) @@ -203,7 +202,7 @@ paginatedSqlQuery = paginatedSqlQueryWithOptions defaultPaginationOptions paginatedSqlQueryWithOptions :: ( FromRowHasql model , ToSnippetParams parameters - , ?context :: ControllerContext + , ?context :: Request , ?modelContext :: ModelContext , ?request :: Request ) diff --git a/ihp/IHP/Pagination/ViewFunctions.hs b/ihp/IHP/Pagination/ViewFunctions.hs index d6553f5c5..4705808ac 100644 --- a/ihp/IHP/Pagination/ViewFunctions.hs +++ b/ihp/IHP/Pagination/ViewFunctions.hs @@ -25,7 +25,7 @@ import IHP.View.Types (PaginationView(..), styledPagination, styledPaginationPag -- | Render a navigation for your pagination. This is to be used in your view whenever -- to allow users to change pages, including "Next" and "Previous". -- If there is only one page, this will not render anything. -renderPagination :: (?context :: ControllerContext, ?request :: Request) => Pagination -> Html +renderPagination :: (?context :: Request, ?request :: Request) => Pagination -> Html renderPagination pagination@Pagination {currentPage, window, pageSize} = when (showPagination pagination) $ styledPagination theCSSFramework theCSSFramework paginationView where @@ -136,7 +136,7 @@ renderPagination pagination@Pagination {currentPage, window, pageSize} = -- -- -- -renderFilter :: (?context::ControllerContext, ?request :: Request) => +renderFilter :: (?context::Request, ?request :: Request) => Text -- ^ Placeholder text for the text box -> Html renderFilter placeholder = diff --git a/ihp/IHP/View/Form/FormFor.hs b/ihp/IHP/View/Form/FormFor.hs index 3bc0d39cd..baf7f0836 100644 --- a/ihp/IHP/View/Form/FormFor.hs +++ b/ihp/IHP/View/Form/FormFor.hs @@ -13,7 +13,6 @@ Copyright: (c) digitally induced GmbH, 2020 -} module IHP.View.Form.FormFor where -import IHP.Controller.Context import IHP.HSX.ConvertibleStrings () import IHP.HSX.MarkupQQ (hsx) import IHP.ModelSupport (Id', InputValue, getModelName, isNew) @@ -89,11 +88,11 @@ import IHP.HSX.Markup (Markup, ToHtml(..)) -- >
This field cannot be empty
-- > formFor :: forall record. ( - ?context :: ControllerContext + ?context :: Request , ?request :: Request , ModelFormAction record , HasField "meta" record MetaBag - ) => record -> ((?context :: ControllerContext, ?formContext :: FormContext record) => Markup) -> Markup + ) => record -> ((?context :: Request, ?formContext :: FormContext record) => Markup) -> Markup formFor record formBody = formForWithOptions @record record (\c -> c) formBody {-# INLINE formFor #-} @@ -114,11 +113,11 @@ formFor record formBody = formForWithOptions @record record (\c -> c) formBody -- > |> set #customFormAttributes [("data-post-id", show formContext.model.id)] -- formForWithOptions :: forall record. ( - ?context :: ControllerContext + ?context :: Request , ?request :: Request , ModelFormAction record , HasField "meta" record MetaBag - ) => record -> (FormContext record -> FormContext record) -> ((?context :: ControllerContext, ?formContext :: FormContext record) => Markup) -> Markup + ) => record -> (FormContext record -> FormContext record) -> ((?context :: Request, ?formContext :: FormContext record) => Markup) -> Markup formForWithOptions record applyOptions formBody = buildForm (applyOptions (createFormContext record) { formAction = modelFormAction record }) formBody {-# INLINE formForWithOptions #-} @@ -148,11 +147,11 @@ formForWithOptions record applyOptions formBody = buildForm (applyOptions (creat -- > |> set #disableJavascriptSubmission True -- formForWithoutJavascript :: forall record. ( - ?context :: ControllerContext + ?context :: Request , ?request :: Request , ModelFormAction record , HasField "meta" record MetaBag - ) => record -> ((?context :: ControllerContext, ?formContext :: FormContext record) => Markup) -> Markup + ) => record -> ((?context :: Request, ?formContext :: FormContext record) => Markup) -> Markup formForWithoutJavascript record formBody = formForWithOptions @record record (\formContext -> formContext { disableJavascriptSubmission = True }) formBody {-# INLINE formForWithoutJavascript #-} @@ -180,10 +179,10 @@ formForWithoutJavascript record formBody = formForWithOptions @record record (\f -- > renderForm post = formFor' post (pathTo CreateDraftAction) [hsx||] -- formFor' :: forall record. ( - ?context :: ControllerContext + ?context :: Request , ?request :: Request , HasField "meta" record MetaBag - ) => record -> Text -> ((?context :: ControllerContext, ?formContext :: FormContext record) => Markup) -> Markup + ) => record -> Text -> ((?context :: Request, ?formContext :: FormContext record) => Markup) -> Markup formFor' record action = buildForm (createFormContext record) { formAction = action } {-# INLINE formFor' #-} @@ -207,7 +206,7 @@ createFormContext record = {-# INLINE createFormContext #-} -- | Used by 'formFor' to render the form -buildForm :: forall model. (?context :: ControllerContext) => FormContext model -> ((?context :: ControllerContext, ?formContext :: FormContext model) => Markup) -> Markup +buildForm :: forall model. (?context :: Request) => FormContext model -> ((?context :: Request, ?formContext :: FormContext model) => Markup) -> Markup buildForm formContext inner = [hsx|
Proxy fieldName -> ((?context :: ControllerContext, ?formContext :: FormContext childRecord) => Markup) -> Markup + ) => Proxy fieldName -> ((?context :: Request, ?formContext :: FormContext childRecord) => Markup) -> Markup nestedFormFor field nestedRenderForm = forEach children renderChild where parentFormContext :: FormContext parentRecord @@ -323,7 +322,7 @@ submitButton = -- | Returns the form's action attribute for a given record. class ModelFormAction record where - modelFormAction :: (?context :: ControllerContext, ?request :: Request) => record -> Text + modelFormAction :: (?context :: Request, ?request :: Request) => record -> Text instance ( HasField "id" record (Id' (GetTableName record)) diff --git a/ihp/IHP/ViewPrelude.hs b/ihp/IHP/ViewPrelude.hs index 36f599e0a..9a8972c9e 100644 --- a/ihp/IHP/ViewPrelude.hs +++ b/ihp/IHP/ViewPrelude.hs @@ -28,7 +28,6 @@ module IHP.ViewPrelude ( module IHP.AutoRefresh.View, module IHP.View.Classes, module IHP.FlashMessages, - module IHP.Controller.Context, module IHP.Controller.Layout, module IHP.Modal.Types, module IHP.Modal.ViewFunctions, @@ -56,7 +55,6 @@ import IHP.AutoRefresh.View import IHP.View.Types import IHP.View.Classes import IHP.FlashMessages -import IHP.Controller.Context import IHP.Controller.Layout import IHP.Modal.Types diff --git a/ihp/IHP/ViewSupport.hs b/ihp/IHP/ViewSupport.hs index 7bf2f610c..8e840232b 100644 --- a/ihp/IHP/ViewSupport.hs +++ b/ihp/IHP/ViewSupport.hs @@ -57,11 +57,11 @@ import IHP.ActionType (isActiveController) class View theView where -- | Hook which is called before the render is called - beforeRender :: (?context :: ControllerContext, ?request :: Request) => theView -> IO () + beforeRender :: (?context :: Request, ?request :: Request) => theView -> IO () beforeRender view = pure () -- Renders the view as html - html :: (?context :: ControllerContext, ?view :: theView, ?request :: Request) => theView -> Markup + html :: (?context :: Request, ?view :: theView, ?request :: Request) => theView -> Markup -- | Implement this for views that can be rendered as JSON. -- Use 'renderHtmlOrJson' in your controller to dispatch based on the Accept header. @@ -213,7 +213,7 @@ nl2br content = content |> map (\line -> [hsx|{line}
|]) |> mconcat -type Html = HtmlWithContext ControllerContext +type Html = HtmlWithContext Request -- | The URL for the dev-mode live reload server. Typically "ws://localhost:8001" liveReloadWebsocketUrl :: (?request :: Request) => Text diff --git a/ihp/IHP/WebSocket.hs b/ihp/IHP/WebSocket.hs index bbe940b95..8f9296785 100644 --- a/ihp/IHP/WebSocket.hs +++ b/ihp/IHP/WebSocket.hs @@ -22,9 +22,9 @@ import Network.WebSockets.Connection.PingPong (withPingPong, defaultPingPongOpti import qualified Data.UUID as UUID import qualified Data.Maybe as Maybe import qualified Control.Exception.Safe as Exception -import IHP.Controller.Context import qualified Data.Aeson as Aeson import Network.Wai (Request) +import IHP.RequestVault () -- HasField "logger"/"frameworkConfig" on Request import qualified IHP.Log as Log @@ -33,13 +33,13 @@ import qualified Network.WebSockets.Connection as WebSocket class WSApp state where initialState :: state - run :: (?state :: IORef state, ?context :: ControllerContext, ?modelContext :: ModelContext, ?connection :: Websocket.Connection, ?request :: Request) => IO () + run :: (?state :: IORef state, ?context :: Request, ?modelContext :: ModelContext, ?connection :: Websocket.Connection, ?request :: Request) => IO () run = pure () - onPing :: (?state :: IORef state, ?context :: ControllerContext, ?modelContext :: ModelContext, ?request :: Request) => IO () + onPing :: (?state :: IORef state, ?context :: Request, ?modelContext :: ModelContext, ?request :: Request) => IO () onPing = pure () - onClose :: (?state :: IORef state, ?context :: ControllerContext, ?modelContext :: ModelContext, ?connection :: Websocket.Connection, ?request :: Request) => IO () + onClose :: (?state :: IORef state, ?context :: Request, ?modelContext :: ModelContext, ?connection :: Websocket.Connection, ?request :: Request) => IO () onClose = pure () -- | Provide WebSocket Connection Options @@ -59,7 +59,7 @@ class WSApp state where connectionOptions :: WebSocket.ConnectionOptions connectionOptions = WebSocket.defaultConnectionOptions -startWSApp :: forall state. (WSApp state, ?context :: ControllerContext, ?modelContext :: ModelContext) => state -> Websocket.Connection -> IO () +startWSApp :: forall state. (WSApp state, ?context :: Request, ?modelContext :: ModelContext) => state -> Websocket.Connection -> IO () startWSApp initialState connection = do state <- newIORef initialState let ?state = state diff --git a/ihp/Test/Test/FileStorage/ControllerFunctionsSpec.hs b/ihp/Test/Test/FileStorage/ControllerFunctionsSpec.hs index cde57615a..e680d4c02 100644 --- a/ihp/Test/Test/FileStorage/ControllerFunctionsSpec.hs +++ b/ihp/Test/Test/FileStorage/ControllerFunctionsSpec.hs @@ -3,7 +3,6 @@ module Test.FileStorage.ControllerFunctionsSpec where import Test.Hspec import IHP.Prelude import IHP.FileStorage.ControllerFunctions -import IHP.Controller.Context import IHP.FrameworkConfig import Network.Wai as Wai (defaultRequest) import qualified Network.Wai as Wai @@ -97,5 +96,4 @@ createControllerContext frameworkConfig = do requestBody = FormBody { params = [], files = [], rawPayload = "" } request = Wai.defaultRequest { Wai.vault = Vault.insert IHP.RequestVault.frameworkConfigVaultKey frameworkConfig $ Vault.insert IHP.RequestVault.requestBodyVaultKey requestBody Vault.empty } - let ?request = request - newControllerContext + pure request diff --git a/ihp/Test/Test/View/FormSpec.hs b/ihp/Test/Test/View/FormSpec.hs index 285f28910..a343a22d3 100644 --- a/ihp/Test/Test/View/FormSpec.hs +++ b/ihp/Test/Test/View/FormSpec.hs @@ -80,7 +80,7 @@ tests = do shouldRenderTo renderFunction expectedHtml = renderMarkupText renderFunction `shouldBe` expectedHtml -createControllerContext :: IO ControllerContext +createControllerContext :: IO Request createControllerContext = do frameworkConfig <- FrameworkConfig.buildFrameworkConfig (pure ()) let requestBody = FormBody { params = [], files = [], rawPayload = "" } diff --git a/ihp/ihp.cabal b/ihp/ihp.cabal index 07d9339bd..6aa6d8322 100644 --- a/ihp/ihp.cabal +++ b/ihp/ihp.cabal @@ -168,7 +168,6 @@ library , IHP.Controller.Redirect , IHP.Controller.Render , IHP.Controller.Session - , IHP.Controller.Context , IHP.Controller.Layout , IHP.Controller.BasicAuth , IHP.Controller.Cookie From c5316c99ae9f273c52e1ccf6ab980cb28510ed09 Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Mon, 13 Apr 2026 16:24:00 +0200 Subject: [PATCH 15/27] Re-trigger CI From d0107e8787fc323ae72c67e7cacf22328e13a097 Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Mon, 13 Apr 2026 16:26:49 +0200 Subject: [PATCH 16/27] Trigger CI again From c734fbc01cd432579b0e6783719b7fd415120f21 Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Mon, 13 Apr 2026 17:16:16 +0200 Subject: [PATCH 17/27] bump From fe5fba597e79784e813d7c83875b83397f18d3c7 Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Mon, 13 Apr 2026 17:47:14 +0200 Subject: [PATCH 18/27] Override ihp-zip with fork that drops removed IHP.Controller.Context import ihp-zip 0.1.0 (Hackage) imports IHP.Controller.Context which this PR deletes. Pin to the digitallyinduced/ihp-zip#2 commit until 0.1.1 ships. Co-Authored-By: Claude Opus 4.6 (1M context) --- NixSupport/overlay.nix | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/NixSupport/overlay.nix b/NixSupport/overlay.nix index 0418068c9..ad313b6d6 100644 --- a/NixSupport/overlay.nix +++ b/NixSupport/overlay.nix @@ -64,7 +64,16 @@ let ihp-migrate = (localPackage "ihp-migrate").overrideAttrs (old: { mainProgram = "migrate"; }); ihp-openai = localPackage "ihp-openai"; ihp-ssc = localPackage "ihp-ssc"; - ihp-zip = fastBuild (hackagePackage "ihp-zip"); + # Override Hackage ihp-zip 0.1.0 with a fork that drops the + # removed IHP.Controller.Context import. Revert once 0.1.1 ships. + ihp-zip = fastBuild (final.haskell.lib.overrideCabal (hackagePackage "ihp-zip") (old: { + src = builtins.fetchTarball { + url = "https://github.com/digitallyinduced/ihp-zip/archive/b716d1935d958bac3202010258b15c4669635a65.tar.gz"; + sha256 = "0q4j15ab0fnhp4m8d0mw4skp64fyfgjipdrmxp9nwbac62yih1fb"; + }; + revision = null; + editedCabalFile = null; + })); ihp-hsx = localPackage "ihp-hsx"; ihp-graphql = localPackage "ihp-graphql"; ihp-datasync-typescript = localPackage "ihp-datasync-typescript"; From f7160c69636fd7fa2d6fd417066884bc927b7f75 Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Mon, 13 Apr 2026 18:26:47 +0200 Subject: [PATCH 19/27] Bump ihp-zip to 0.1.1 from Hackage, drop overlay override ihp-zip 0.1.1 is now on Hackage with the fix for the removed IHP.Controller.Context import, so we can use the regular Hackage-based pin and remove the temporary fetchTarball override. Co-Authored-By: Claude Opus 4.6 (1M context) --- NixSupport/hackage/ihp-zip.nix | 4 ++-- NixSupport/overlay.nix | 11 +---------- update-nix-from-cabal.sh | 2 +- 3 files changed, 4 insertions(+), 13 deletions(-) diff --git a/NixSupport/hackage/ihp-zip.nix b/NixSupport/hackage/ihp-zip.nix index 273240a0c..907d594f4 100644 --- a/NixSupport/hackage/ihp-zip.nix +++ b/NixSupport/hackage/ihp-zip.nix @@ -1,8 +1,8 @@ { mkDerivation, base, http-types, ihp, lib, wai, zip-archive }: mkDerivation { pname = "ihp-zip"; - version = "0.1.0"; - sha256 = "3ff75acfca08231d2ea365369a42b4b8f1abf05df64a980116eed193a778d860"; + version = "0.1.1"; + sha256 = "1hkx1rf4h297bjjwwf6ckxg6jp7bvr2z92vy4a67n33k8l7mhi18"; libraryHaskellDepends = [ base http-types ihp wai zip-archive ]; homepage = "https://ihp.digitallyinduced.com/"; description = "Support for making ZIP archives with IHP"; diff --git a/NixSupport/overlay.nix b/NixSupport/overlay.nix index ad313b6d6..0418068c9 100644 --- a/NixSupport/overlay.nix +++ b/NixSupport/overlay.nix @@ -64,16 +64,7 @@ let ihp-migrate = (localPackage "ihp-migrate").overrideAttrs (old: { mainProgram = "migrate"; }); ihp-openai = localPackage "ihp-openai"; ihp-ssc = localPackage "ihp-ssc"; - # Override Hackage ihp-zip 0.1.0 with a fork that drops the - # removed IHP.Controller.Context import. Revert once 0.1.1 ships. - ihp-zip = fastBuild (final.haskell.lib.overrideCabal (hackagePackage "ihp-zip") (old: { - src = builtins.fetchTarball { - url = "https://github.com/digitallyinduced/ihp-zip/archive/b716d1935d958bac3202010258b15c4669635a65.tar.gz"; - sha256 = "0q4j15ab0fnhp4m8d0mw4skp64fyfgjipdrmxp9nwbac62yih1fb"; - }; - revision = null; - editedCabalFile = null; - })); + ihp-zip = fastBuild (hackagePackage "ihp-zip"); ihp-hsx = localPackage "ihp-hsx"; ihp-graphql = localPackage "ihp-graphql"; ihp-datasync-typescript = localPackage "ihp-datasync-typescript"; diff --git a/update-nix-from-cabal.sh b/update-nix-from-cabal.sh index 51a5cc8f0..6c31c36a1 100755 --- a/update-nix-from-cabal.sh +++ b/update-nix-from-cabal.sh @@ -44,7 +44,7 @@ hackage_packages=( "postgresql-types 0.1.2" "hasql-mapping 0.1" "hasql-postgresql-types 0.2" - "ihp-zip 0.1.0" + "ihp-zip 0.1.1" ) for entry in "${hackage_packages[@]}"; do From bba8d8dd1c2a2bab2274da425bcb16b3937cc523 Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Mon, 13 Apr 2026 20:31:58 +0200 Subject: [PATCH 20/27] Drop duplicate ?context :: Request from signatures that also have ?request Since ControllerContext is a type alias for Request, having both ?context :: Request and ?request :: Request in a constraint set was pure duplication. Keep ?request as the canonical name. Where function bodies still need ?context in scope (for Log/urlTo/getAppConfig calls), add a local 'let ?context = ?request' shim. Top-level class constraints (Controller.action, View.html, etc.) keep ?context so user code calling Log/urlTo doesn't need to bind it themselves. Co-Authored-By: Claude Opus 4.6 (1M context) --- ihp-datasync/IHP/DataSync/REST/Controller.hs | 2 +- ihp-ide/IHP/IDE/Prelude.hs | 7 +++++-- .../IDE/SchemaDesigner/View/Columns/NewForeignKey.hs | 2 +- ihp-ide/IHP/IDE/ToolServer/Layout.hs | 2 +- ihp-job-dashboard/IHP/Job/Dashboard.hs | 2 +- ihp-sitemap/IHP/SEO/Sitemap/ControllerFunctions.hs | 2 +- .../IHP/ServerSideComponent/ControllerFunctions.hs | 2 +- ihp/IHP/Controller/Layout.hs | 4 ++-- ihp/IHP/Controller/Render.hs | 9 +++++---- ihp/IHP/ControllerPrelude.hs | 7 +++++-- ihp/IHP/ErrorController.hs | 7 ++++--- ihp/IHP/LoginSupport/Helper/Controller.hs | 12 ++++++------ ihp/IHP/Pagination/ViewFunctions.hs | 2 +- ihp/IHP/View/Form/FormFor.hs | 2 +- ihp/IHP/ViewSupport.hs | 2 +- 15 files changed, 36 insertions(+), 28 deletions(-) diff --git a/ihp-datasync/IHP/DataSync/REST/Controller.hs b/ihp-datasync/IHP/DataSync/REST/Controller.hs index f469a1368..460e393e4 100644 --- a/ihp-datasync/IHP/DataSync/REST/Controller.hs +++ b/ihp-datasync/IHP/DataSync/REST/Controller.hs @@ -201,7 +201,7 @@ encodeKeyMapToSetSql columnTypes hashMap = setSnippets = map encodeSetClause pairsList in mconcat $ List.intersperse (Snippet.sql ", ") setSnippets -renderErrorJson :: (?context :: Request, ?request :: Request, ?respond :: Respond) => ToJSON json => json -> IO ResponseReceived +renderErrorJson :: (?request :: Request, ?respond :: Respond) => ToJSON json => json -> IO ResponseReceived renderErrorJson json = renderJsonWithStatusCode status400 json {-# INLINABLE renderErrorJson #-} diff --git a/ihp-ide/IHP/IDE/Prelude.hs b/ihp-ide/IHP/IDE/Prelude.hs index 8160164e1..6215f6aa4 100644 --- a/ihp-ide/IHP/IDE/Prelude.hs +++ b/ihp-ide/IHP/IDE/Prelude.hs @@ -34,5 +34,8 @@ import IHP.ValidationSupport -- -- > setModal MyModalView { .. } -- -setModal :: (?context :: Request, ?request :: Request, View view) => view -> IO () -setModal view = let ?view = view in Modal.setModal (ViewSupport.html view) +setModal :: (?request :: Request, View view) => view -> IO () +setModal view = + let ?context = ?request + ?view = view + in Modal.setModal (ViewSupport.html view) diff --git a/ihp-ide/IHP/IDE/SchemaDesigner/View/Columns/NewForeignKey.hs b/ihp-ide/IHP/IDE/SchemaDesigner/View/Columns/NewForeignKey.hs index e3649b4ac..0b8c8532e 100644 --- a/ihp-ide/IHP/IDE/SchemaDesigner/View/Columns/NewForeignKey.hs +++ b/ihp-ide/IHP/IDE/SchemaDesigner/View/Columns/NewForeignKey.hs @@ -36,7 +36,7 @@ instance View NewForeignKeyView where -- | Shared form modal for creating and editing foreign key constraints. foreignKeyFormModal - :: (?context :: Request, ?request :: Request) + :: (?request :: Request) => Text -- ^ Form action URL -> Text -- ^ Table name -> Text -- ^ Column name diff --git a/ihp-ide/IHP/IDE/ToolServer/Layout.hs b/ihp-ide/IHP/IDE/ToolServer/Layout.hs index 3e9762e0b..2a59d21d4 100644 --- a/ihp-ide/IHP/IDE/ToolServer/Layout.hs +++ b/ihp-ide/IHP/IDE/ToolServer/Layout.hs @@ -166,7 +166,7 @@ toolServerLayout inner = [hsx| target :: Maybe Text target = if isExternal then "_blank" else Nothing -appUrl :: (?context :: Request, ?request :: Request) => Text +appUrl :: (?request :: Request) => Text appUrl = let (AppUrl url) = lookupRequestVault appUrlVaultKey ?request in url -- | https://github.com/encharm/Font-Awesome-SVG-PNG/blob/master/white/svg/terminal.svg diff --git a/ihp-job-dashboard/IHP/Job/Dashboard.hs b/ihp-job-dashboard/IHP/Job/Dashboard.hs index d62a05bec..b6a7752a2 100644 --- a/ihp-job-dashboard/IHP/Job/Dashboard.hs +++ b/ihp-job-dashboard/IHP/Job/Dashboard.hs @@ -375,7 +375,7 @@ getNotIncludedTableNames includedNames = sqlQueryHasql getHasqlPool (Snippet.sql "SELECT table_name::text FROM information_schema.tables WHERE table_name LIKE '%_jobs' AND NOT (table_name = ANY(" <> Snippet.param includedNames <> Snippet.sql "))") (Decoders.rowList (Decoders.column (Decoders.nonNullable Decoders.text))) -buildBaseJobTable :: (?modelContext :: ModelContext, ?context :: Request, ?request :: Request) => Text -> IO SomeView +buildBaseJobTable :: (?modelContext :: ModelContext, ?request :: Request) => Text -> IO SomeView buildBaseJobTable tableName = do baseJobs <- sqlQueryHasql getHasqlPool (Snippet.sql "SELECT " <> Snippet.param tableName <> Snippet.sql ", id, status, updated_at, created_at, last_error FROM " diff --git a/ihp-sitemap/IHP/SEO/Sitemap/ControllerFunctions.hs b/ihp-sitemap/IHP/SEO/Sitemap/ControllerFunctions.hs index a30a47033..85090dad2 100644 --- a/ihp-sitemap/IHP/SEO/Sitemap/ControllerFunctions.hs +++ b/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 :: Request, ?request :: Request, ?respond :: Respond) => Sitemap -> IO ResponseReceived +renderXmlSitemap :: (?request :: Request, ?respond :: Respond) => Sitemap -> IO ResponseReceived renderXmlSitemap Sitemap { links } = do let sitemap = Markup.toMarkup [xmlDocument, sitemapLinks] renderXml $ Markup.renderMarkup sitemap diff --git a/ihp-ssc/IHP/ServerSideComponent/ControllerFunctions.hs b/ihp-ssc/IHP/ServerSideComponent/ControllerFunctions.hs index a6b60f3e8..350e2a315 100644 --- a/ihp-ssc/IHP/ServerSideComponent/ControllerFunctions.hs +++ b/ihp-ssc/IHP/ServerSideComponent/ControllerFunctions.hs @@ -26,7 +26,7 @@ $(Aeson.deriveJSON Aeson.defaultOptions { sumEncoding = defaultTaggedObject { ta $(Aeson.deriveJSON Aeson.defaultOptions { sumEncoding = defaultTaggedObject { tagFieldName = "type" }} ''NodeOperation) $(Aeson.deriveJSON Aeson.defaultOptions { sumEncoding = defaultTaggedObject { tagFieldName = "type" }} ''SSCError) -setState :: (?instanceRef :: IORef (ComponentInstance state), ?connection :: WebSocket.Connection, Component state action, ?context :: Request, ?request :: Request) => state -> IO () +setState :: (?instanceRef :: IORef (ComponentInstance state), ?connection :: WebSocket.Connection, Component state action, ?request :: Request) => state -> IO () setState state = do oldState <- (.state) <$> readIORef ?instanceRef let oldHtml = oldState diff --git a/ihp/IHP/Controller/Layout.hs b/ihp/IHP/Controller/Layout.hs index 8bebf35b6..5d1d7a546 100644 --- a/ihp/IHP/Controller/Layout.hs +++ b/ihp/IHP/Controller/Layout.hs @@ -18,7 +18,7 @@ import qualified Data.Vault.Lazy as Vault import Data.IORef -- | Wrapper for a layout function that will be applied to views -newtype ViewLayout = ViewLayout ((?context :: Request, ?request :: Request) => Layout) +newtype ViewLayout = ViewLayout ((?request :: Request) => Layout) -- | Vault key for storing the mutable layout IORef in each request viewLayoutVaultKey :: Vault.Key (IORef ViewLayout) @@ -42,7 +42,7 @@ viewLayoutMiddleware app request respond = do -- > initContext = do -- > setLayout defaultLayout -- -setLayout :: (?context :: Request, ?request :: Request) => ((?context :: Request, ?request :: Request) => Layout) -> IO () +setLayout :: (?request :: Request) => ((?request :: Request) => Layout) -> IO () setLayout layout = case Vault.lookup viewLayoutVaultKey (vault ?request) of Just ref -> writeIORef ref (ViewLayout layout) diff --git a/ihp/IHP/Controller/Render.hs b/ihp/IHP/Controller/Render.hs index 9da7664a7..aa3578971 100644 --- a/ihp/IHP/Controller/Render.hs +++ b/ihp/IHP/Controller/Render.hs @@ -30,8 +30,9 @@ respondSvg (Markup builder) = respondWith $ responseBuilder status200 [(hContentType, "image/svg+xml"), (hConnection, "keep-alive")] builder {-# INLINABLE respondSvg #-} -renderHtml :: forall view. (ViewSupport.View view, ?context :: Request, ?request :: Request) => view -> IO Markup +renderHtml :: forall view. (ViewSupport.View view, ?request :: Request) => view -> IO Markup renderHtml !view = do + let ?context = ?request let ?view = view ViewSupport.beforeRender view (ViewLayout layout) <- getLayout @@ -60,7 +61,7 @@ renderJson' additionalHeaders json = respondWith $ responseLBS status200 ([(hCon {-# INLINE renderJson' #-} {-# INLINE render #-} -render :: forall view. (ViewSupport.View view, ?context :: Request, ?request :: Request, ?respond :: Respond) => view -> IO ResponseReceived +render :: forall view. (ViewSupport.View view, ?request :: Request, ?respond :: Respond) => view -> IO ResponseReceived render !view = do let !currentRequest = ?request renderHtmlView currentRequest view @@ -68,7 +69,7 @@ render !view = do -- | Renders HTML or JSON based on the request's Accept header. -- Requires both 'View' and 'JsonView' instances for the view type. {-# INLINE renderHtmlOrJson #-} -renderHtmlOrJson :: forall view. (ViewSupport.View view, ViewSupport.JsonView view, ?context :: Request, ?request :: Request, ?respond :: Respond) => view -> IO ResponseReceived +renderHtmlOrJson :: forall view. (ViewSupport.View view, ViewSupport.JsonView view, ?request :: Request, ?respond :: Respond) => view -> IO ResponseReceived renderHtmlOrJson !view = do let !currentRequest = ?request let acceptHeader = lookup hAccept (?request.requestHeaders) @@ -84,7 +85,7 @@ renderHtmlOrJson !view = do ] fromMaybe send406Error (Accept.mapAcceptMedia formats accept) -renderHtmlView :: (ViewSupport.View view, ?context :: Request, ?respond :: Respond) => Request -> view -> IO ResponseReceived +renderHtmlView :: (ViewSupport.View view, ?respond :: Respond) => Request -> view -> IO ResponseReceived renderHtmlView currentRequest view = do let next request respond = do let ?request = request diff --git a/ihp/IHP/ControllerPrelude.hs b/ihp/IHP/ControllerPrelude.hs index d1b2596ce..ef9c46ef9 100644 --- a/ihp/IHP/ControllerPrelude.hs +++ b/ihp/IHP/ControllerPrelude.hs @@ -89,5 +89,8 @@ import IHP.HSX.MarkupQQ (hsx, uncheckedHsx, customHsx) -- -- > setModal MyModalView { .. } -- -setModal :: (?context :: Request, ?request :: Request, View view) => view -> IO () -setModal view = let ?view = view in Modal.setModal (ViewSupport.html view) +setModal :: (?request :: Request, View view) => view -> IO () +setModal view = + let ?context = ?request + ?view = view + in Modal.setModal (ViewSupport.html view) diff --git a/ihp/IHP/ErrorController.hs b/ihp/IHP/ErrorController.hs index e04698e40..f3e2b4c51 100644 --- a/ihp/IHP/ErrorController.hs +++ b/ihp/IHP/ErrorController.hs @@ -111,8 +111,9 @@ respondError request environment status title body json [(hContentType, "text/html")] (getBuilder (renderError environment title body)) -displayException :: (Show action, ?context :: Request, ?request :: Request, ?respond :: Respond) => SomeException -> action -> Text -> IO ResponseReceived +displayException :: (Show action, ?request :: Request, ?respond :: Respond) => SomeException -> action -> Text -> IO ResponseReceived displayException exception action additionalInfo = do + let ?context = ?request -- Dev handlers display helpful tips on how to resolve the problem let devHandlers = [ postgresHandler @@ -285,7 +286,7 @@ patternMatchFailureHandler exception controller additionalInfo = do -- Handler for 'IHP.Controller.Param.ParamNotFoundException' -- Only used in dev mode of the app. -paramNotFoundExceptionHandler :: (Show controller, ?context :: Request, ?request :: Request, ?respond :: Respond) => SomeException -> controller -> Text -> Maybe (IO ResponseReceived) +paramNotFoundExceptionHandler :: (Show controller, ?request :: Request, ?respond :: Respond) => SomeException -> controller -> Text -> Maybe (IO ResponseReceived) paramNotFoundExceptionHandler exception controller additionalInfo = do case fromException exception of Just (exception@(Param.ParamNotFoundException paramName)) -> Just do @@ -390,7 +391,7 @@ recordNotFoundExceptionHandlerDev exception controller additionalInfo = -- Handler for 'IHP.ModelSupport.RecordNotFoundException' -- -- Used only in production mode of the app. The exception is handled by calling 'handleNotFound' -recordNotFoundExceptionHandlerProd :: (?context :: Request, ?request :: Request, ?respond :: Respond) => SomeException -> controller -> Text -> Maybe (IO ResponseReceived) +recordNotFoundExceptionHandlerProd :: (?request :: Request, ?respond :: Respond) => SomeException -> controller -> Text -> Maybe (IO ResponseReceived) recordNotFoundExceptionHandlerProd exception controller additionalInfo = case fromException exception of Just (exception@(ModelSupport.RecordNotFoundException {})) -> diff --git a/ihp/IHP/LoginSupport/Helper/Controller.hs b/ihp/IHP/LoginSupport/Helper/Controller.hs index ad30fdc66..4cb73aab6 100644 --- a/ihp/IHP/LoginSupport/Helper/Controller.hs +++ b/ihp/IHP/LoginSupport/Helper/Controller.hs @@ -44,17 +44,17 @@ currentUserOrNothing = lookupAuthVault currentUserVaultKey ?request {-# INLINE currentUserOrNothing #-} -- | Returns the current user. Redirects to login if not logged in. -currentUser :: forall user. (?context :: Request, ?request :: Request, ?respond :: Respond, HasNewSessionUrl user, Typeable user, user ~ CurrentUserRecord) => user +currentUser :: forall user. (?request :: Request, ?respond :: Respond, HasNewSessionUrl user, Typeable user, user ~ CurrentUserRecord) => user currentUser = fromMaybe (redirectToLogin (newSessionUrl (Proxy @user))) currentUserOrNothing {-# INLINABLE currentUser #-} -- | Returns the ID of the current user. Redirects to login if not logged in. -currentUserId :: forall user userId. (?context :: Request, ?request :: Request, ?respond :: Respond, HasNewSessionUrl user, HasField "id" user userId, Typeable user, user ~ CurrentUserRecord) => userId +currentUserId :: forall user userId. (?request :: Request, ?respond :: Respond, HasNewSessionUrl user, HasField "id" user userId, Typeable user, user ~ CurrentUserRecord) => userId currentUserId = (currentUser @user).id {-# INLINABLE currentUserId #-} -- | Ensures that a user is logged in. Redirects to login page if not. -ensureIsUser :: forall user. (?context :: Request, ?request :: Request, ?respond :: Respond, HasNewSessionUrl user, Typeable user, user ~ CurrentUserRecord) => IO () +ensureIsUser :: forall user. (?request :: Request, ?respond :: Respond, HasNewSessionUrl user, Typeable user, user ~ CurrentUserRecord) => IO () ensureIsUser = case currentUserOrNothing @user of Just _ -> pure () @@ -80,12 +80,12 @@ currentAdminOrNothing = lookupAuthVault currentAdminVaultKey ?request {-# INLINE currentAdminOrNothing #-} -- | Returns the current admin. Redirects to login if not logged in. -currentAdmin :: forall admin. (?context :: Request, ?request :: Request, ?respond :: Respond, HasNewSessionUrl admin, Typeable admin, admin ~ CurrentAdminRecord) => admin +currentAdmin :: forall admin. (?request :: Request, ?respond :: Respond, HasNewSessionUrl admin, Typeable admin, admin ~ CurrentAdminRecord) => admin currentAdmin = fromMaybe (redirectToLogin (newSessionUrl (Proxy @admin))) currentAdminOrNothing {-# INLINABLE currentAdmin #-} -- | Returns the ID of the current admin. Redirects to login if not logged in. -currentAdminId :: forall admin adminId. (?context :: Request, ?request :: Request, ?respond :: Respond, HasNewSessionUrl admin, HasField "id" admin adminId, Typeable admin, admin ~ CurrentAdminRecord) => adminId +currentAdminId :: forall admin adminId. (?request :: Request, ?respond :: Respond, HasNewSessionUrl admin, HasField "id" admin adminId, Typeable admin, admin ~ CurrentAdminRecord) => adminId currentAdminId = (currentAdmin @admin).id {-# INLINABLE currentAdminId #-} @@ -97,7 +97,7 @@ currentAdminIdOrNothing = ModelSupport.Id <$> lookupAuthVault currentAdminIdVaul {-# INLINE currentAdminIdOrNothing #-} -- | Ensures that an admin is logged in. Redirects to login page if not. -ensureIsAdmin :: forall (admin :: Type). (?context :: Request, ?request :: Request, ?respond :: Respond, HasNewSessionUrl admin, Typeable admin, admin ~ CurrentAdminRecord) => IO () +ensureIsAdmin :: forall (admin :: Type). (?request :: Request, ?respond :: Respond, HasNewSessionUrl admin, Typeable admin, admin ~ CurrentAdminRecord) => IO () ensureIsAdmin = case currentAdminOrNothing @admin of Just _ -> pure () diff --git a/ihp/IHP/Pagination/ViewFunctions.hs b/ihp/IHP/Pagination/ViewFunctions.hs index 4705808ac..0c9a85913 100644 --- a/ihp/IHP/Pagination/ViewFunctions.hs +++ b/ihp/IHP/Pagination/ViewFunctions.hs @@ -25,7 +25,7 @@ import IHP.View.Types (PaginationView(..), styledPagination, styledPaginationPag -- | Render a navigation for your pagination. This is to be used in your view whenever -- to allow users to change pages, including "Next" and "Previous". -- If there is only one page, this will not render anything. -renderPagination :: (?context :: Request, ?request :: Request) => Pagination -> Html +renderPagination :: (?request :: Request) => Pagination -> Html renderPagination pagination@Pagination {currentPage, window, pageSize} = when (showPagination pagination) $ styledPagination theCSSFramework theCSSFramework paginationView where diff --git a/ihp/IHP/View/Form/FormFor.hs b/ihp/IHP/View/Form/FormFor.hs index baf7f0836..1eef498d4 100644 --- a/ihp/IHP/View/Form/FormFor.hs +++ b/ihp/IHP/View/Form/FormFor.hs @@ -322,7 +322,7 @@ submitButton = -- | Returns the form's action attribute for a given record. class ModelFormAction record where - modelFormAction :: (?context :: Request, ?request :: Request) => record -> Text + modelFormAction :: (?request :: Request) => record -> Text instance ( HasField "id" record (Id' (GetTableName record)) diff --git a/ihp/IHP/ViewSupport.hs b/ihp/IHP/ViewSupport.hs index 8e840232b..418c2ed8b 100644 --- a/ihp/IHP/ViewSupport.hs +++ b/ihp/IHP/ViewSupport.hs @@ -57,7 +57,7 @@ import IHP.ActionType (isActiveController) class View theView where -- | Hook which is called before the render is called - beforeRender :: (?context :: Request, ?request :: Request) => theView -> IO () + beforeRender :: (?request :: Request) => theView -> IO () beforeRender view = pure () -- Renders the view as html From 66062798b1fd00b31d84b4d450c01e351e9eed20 Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Tue, 14 Apr 2026 11:14:11 +0200 Subject: [PATCH 21/27] Rename ?context :: Request to ?request :: Request in framework internals MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Since ControllerContext is a type alias for Request, the ?context and ?request implicit parameters were carrying the same value. Rename ?context :: Request to ?request :: Request in framework function signatures (and corresponding body references to ?request.field). Polymorphic signatures (?context :: context with LoggingProvider / ConfigProvider constraints) are left alone — those still use ?context so jobs can bind 'let ?context = frameworkConfig' and call Log/urlTo. Where a function body still needs ?context in scope (e.g. to call Log.error / isEnvironment / getAppConfig), a local 'let ?context = ?request' shim is added. Top-level View class constraint keeps ?context :: Request so that user view code (which the framework renders via renderHtml) has ?context in scope for hsx route/asset helpers. Co-Authored-By: Claude Opus 4.6 (1M context) --- ihp-datasync/IHP/DataSync/ControllerImpl.hs | 18 +++++----- ihp-datasync/IHP/DataSync/RowLevelSecurity.hs | 18 +++++----- .../IDE/SchemaDesigner/Controller/Helper.hs | 4 +-- ihp-job-dashboard/IHP/Job/Dashboard.hs | 34 +++++++++---------- ihp-job-dashboard/IHP/Job/Dashboard/Auth.hs | 2 +- ihp-job-dashboard/IHP/Job/Dashboard/Types.hs | 4 +-- ihp-job-dashboard/IHP/Job/Dashboard/View.hs | 4 +-- ihp-ssc/IHP/ServerSideComponent/Types.hs | 4 +-- ihp/IHP/AuthSupport/Controller/Sessions.hs | 10 +++--- ihp/IHP/AutoRefresh.hs | 10 +++--- ihp/IHP/AutoRefresh/View.hs | 4 +-- ihp/IHP/ErrorController.hs | 10 +++--- ihp/IHP/FileStorage/ControllerFunctions.hs | 16 +++++---- ihp/IHP/LoginSupport/Helper/Controller.hs | 5 ++- ihp/IHP/Pagination/ControllerFunctions.hs | 10 +++--- ihp/IHP/Pagination/ViewFunctions.hs | 2 +- ihp/IHP/View/Form/FormFor.hs | 22 ++++++------ ihp/IHP/ViewSupport.hs | 2 +- ihp/IHP/WebSocket.hs | 10 +++--- 19 files changed, 96 insertions(+), 93 deletions(-) diff --git a/ihp-datasync/IHP/DataSync/ControllerImpl.hs b/ihp-datasync/IHP/DataSync/ControllerImpl.hs index df3f44848..a260c8875 100644 --- a/ihp-datasync/IHP/DataSync/ControllerImpl.hs +++ b/ihp-datasync/IHP/DataSync/ControllerImpl.hs @@ -41,7 +41,7 @@ type HandleCustomMessageFn = (DataSyncResponse -> IO ()) -> DataSyncMessage -> I runDataSyncController :: ( HasField "id" CurrentUserRecord (Id' (GetTableName CurrentUserRecord)) - , ?context :: Request + , ?request :: Request , ?modelContext :: ModelContext , ?request :: Request , ?state :: IORef DataSyncController @@ -106,7 +106,7 @@ runDataSyncController hasqlPool ensureRLSEnabled installTableChangeTriggers rece buildMessageHandler :: ( HasField "id" CurrentUserRecord (Id' (GetTableName CurrentUserRecord)) - , ?context :: Request + , ?request :: Request , ?modelContext :: ModelContext , ?request :: Request , ?state :: IORef DataSyncController @@ -465,26 +465,26 @@ findTransactionById transactionId = do -- concurrent transactions. Then all database connections are removed from the connection pool and further database -- queries for other users will fail. -- -ensureBelowTransactionLimit :: (?state :: IORef DataSyncController, ?context :: Request) => IO () +ensureBelowTransactionLimit :: (?state :: IORef DataSyncController, ?request :: Request) => IO () ensureBelowTransactionLimit = do transactions <- (.transactions) <$> readIORef ?state let transactionCount = HashMap.size transactions when (transactionCount >= maxTransactionsPerConnection) do Exception.throwIO (userError ("You've reached the transaction limit of " <> cs (tshow maxTransactionsPerConnection) <> " transactions")) -ensureBelowSubscriptionsLimit :: (?state :: IORef DataSyncController, ?context :: Request) => IO () +ensureBelowSubscriptionsLimit :: (?state :: IORef DataSyncController, ?request :: Request) => IO () ensureBelowSubscriptionsLimit = do subscriptions <- (.subscriptions) <$> readIORef ?state let subscriptionsCount = HashMap.size subscriptions when (subscriptionsCount >= maxSubscriptionsPerConnection) do Exception.throwIO (userError ("You've reached the subscriptions limit of " <> cs (tshow maxSubscriptionsPerConnection) <> " subscriptions")) -maxTransactionsPerConnection :: (?context :: Request) => Int +maxTransactionsPerConnection :: (?request :: Request) => Int maxTransactionsPerConnection = case getAppConfig @DataSyncMaxTransactionsPerConnection of DataSyncMaxTransactionsPerConnection value -> value -maxSubscriptionsPerConnection :: (?context :: Request) => Int +maxSubscriptionsPerConnection :: (?request :: Request) => Int maxSubscriptionsPerConnection = case getAppConfig @DataSyncMaxSubscriptionsPerConnection of DataSyncMaxSubscriptionsPerConnection value -> value @@ -504,7 +504,7 @@ encodePatchToSetSql ren columnTypes patch = in mconcat $ List.intersperse (Snippet.sql ", ") setSnippets sqlQueryWithRLSAndTransactionId :: - ( ?context :: Request + ( ?request :: Request , ?request :: Request , Show (PrimaryKey (GetTableName CurrentUserRecord)) , HasNewSessionUrl CurrentUserRecord @@ -524,7 +524,7 @@ sqlQueryWithRLSAndTransactionId pool Nothing statement = runSession pool (sqlQue -- Use this for INSERT, UPDATE, or DELETE statements with RETURNING that need -- to return results (e.g. wrapped with 'wrapDynamicQuery'). sqlQueryWriteWithRLSAndTransactionId :: - ( ?context :: Request + ( ?request :: Request , ?request :: Request , Show (PrimaryKey (GetTableName CurrentUserRecord)) , HasNewSessionUrl CurrentUserRecord @@ -540,7 +540,7 @@ sqlQueryWriteWithRLSAndTransactionId _pool (Just transactionId) statement = do sqlQueryWriteWithRLSAndTransactionId pool Nothing statement = runSession pool (sqlQueryWriteWithRLSSession statement) sqlExecWithRLSAndTransactionId :: - ( ?context :: Request + ( ?request :: Request , ?request :: Request , Show (PrimaryKey (GetTableName CurrentUserRecord)) , HasNewSessionUrl CurrentUserRecord diff --git a/ihp-datasync/IHP/DataSync/RowLevelSecurity.hs b/ihp-datasync/IHP/DataSync/RowLevelSecurity.hs index a759b76ab..ee5215dae 100644 --- a/ihp-datasync/IHP/DataSync/RowLevelSecurity.hs +++ b/ihp-datasync/IHP/DataSync/RowLevelSecurity.hs @@ -57,7 +57,7 @@ ensureRLSEnabledSession table = do -- This is a Session-level action for use in user-managed transactions -- (e.g. after a manual @BEGIN@). setRLSConfigSession :: - ( ?context :: Request + ( ?request :: Request , ?request :: Request , Show (PrimaryKey (GetTableName CurrentUserRecord)) , HasNewSessionUrl CurrentUserRecord @@ -71,7 +71,7 @@ setRLSConfigSession = Session.statement (Role.authenticatedRole, encodedUserId) Nothing -> "" sqlQueryWithRLSSession :: - ( ?context :: Request + ( ?request :: Request , ?request :: Request , Show (PrimaryKey (GetTableName CurrentUserRecord)) , HasNewSessionUrl CurrentUserRecord @@ -93,7 +93,7 @@ sqlQueryWithRLSSession statement = -- Use this for INSERT, UPDATE, or DELETE statements with RETURNING that need -- to return results (e.g. wrapped with 'wrapDynamicQuery'). sqlQueryWriteWithRLSSession :: - ( ?context :: Request + ( ?request :: Request , ?request :: Request , Show (PrimaryKey (GetTableName CurrentUserRecord)) , HasNewSessionUrl CurrentUserRecord @@ -111,7 +111,7 @@ sqlQueryWriteWithRLSSession statement = {-# INLINE sqlQueryWriteWithRLSSession #-} sqlExecWithRLSSession :: - ( ?context :: Request + ( ?request :: Request , ?request :: Request , Show (PrimaryKey (GetTableName CurrentUserRecord)) , HasNewSessionUrl CurrentUserRecord @@ -129,7 +129,7 @@ sqlExecWithRLSSession statement = {-# INLINE sqlExecWithRLSSession #-} sqlQueryScalarWithRLSSession :: - ( ?context :: Request + ( ?request :: Request , ?request :: Request , Show (PrimaryKey (GetTableName CurrentUserRecord)) , HasNewSessionUrl CurrentUserRecord @@ -149,7 +149,7 @@ sqlQueryScalarWithRLSSession statement = -- IO API (thin wrappers) sqlQueryWithRLS :: - ( ?context :: Request + ( ?request :: Request , ?request :: Request , Show (PrimaryKey (GetTableName CurrentUserRecord)) , HasNewSessionUrl CurrentUserRecord @@ -164,7 +164,7 @@ sqlQueryWithRLS pool statement = runSession pool (sqlQueryWithRLSSession stateme -- Use this for INSERT, UPDATE, or DELETE statements with RETURNING that need -- to return results (e.g. wrapped with 'wrapDynamicQuery'). sqlQueryWriteWithRLS :: - ( ?context :: Request + ( ?request :: Request , ?request :: Request , Show (PrimaryKey (GetTableName CurrentUserRecord)) , HasNewSessionUrl CurrentUserRecord @@ -175,7 +175,7 @@ sqlQueryWriteWithRLS pool statement = runSession pool (sqlQueryWriteWithRLSSessi {-# INLINE sqlQueryWriteWithRLS #-} sqlExecWithRLS :: - ( ?context :: Request + ( ?request :: Request , ?request :: Request , Show (PrimaryKey (GetTableName CurrentUserRecord)) , HasNewSessionUrl CurrentUserRecord @@ -186,7 +186,7 @@ sqlExecWithRLS pool statement = runSession pool (sqlExecWithRLSSession statement {-# INLINE sqlExecWithRLS #-} sqlQueryScalarWithRLS :: - ( ?context :: Request + ( ?request :: Request , ?request :: Request , Show (PrimaryKey (GetTableName CurrentUserRecord)) , HasNewSessionUrl CurrentUserRecord diff --git a/ihp-ide/IHP/IDE/SchemaDesigner/Controller/Helper.hs b/ihp-ide/IHP/IDE/SchemaDesigner/Controller/Helper.hs index 863bb21ca..daaaa11d2 100644 --- a/ihp-ide/IHP/IDE/SchemaDesigner/Controller/Helper.hs +++ b/ihp-ide/IHP/IDE/SchemaDesigner/Controller/Helper.hs @@ -25,7 +25,7 @@ instance ParamReader [IndexColumn] where Right result -> Right result readSchema :: - ( ?context::Request + ( ?request::Request , ?modelContext::ModelContext , ?theAction::controller , ?respond::Respond @@ -41,7 +41,7 @@ getSqlError = SchemaDesignerParser.parseSchemaSql >>= \case Right statements -> do pure Nothing updateSchema :: - ( ?context :: Request + ( ?request :: Request , ?modelContext::ModelContext , ?theAction::controller , ?respond::Respond diff --git a/ihp-job-dashboard/IHP/Job/Dashboard.hs b/ihp-job-dashboard/IHP/Job/Dashboard.hs index b6a7752a2..cb7206005 100644 --- a/ihp-job-dashboard/IHP/Job/Dashboard.hs +++ b/ihp-job-dashboard/IHP/Job/Dashboard.hs @@ -76,27 +76,27 @@ class ( job ~ GetModelByTableName (GetTableName job) -- | How this job's section should be displayed in the dashboard. By default it's displayed as a table, -- but this can be any arbitrary view! Make some cool graphs :) - makeDashboardSection :: (?context :: Request, ?modelContext :: ModelContext) => IO SomeView + makeDashboardSection :: (?request :: Request, ?modelContext :: ModelContext) => IO SomeView - makePageView :: (?context :: Request, ?modelContext :: ModelContext) => Int -> Int -> IO SomeView + makePageView :: (?request :: Request, ?modelContext :: ModelContext) => Int -> Int -> IO SomeView -- | The content of the page that will be displayed for a detail view of this job. -- By default, the ID, Status, Created/Updated at times, and last error are displayed. -- Can be defined as any arbitrary view. - makeDetailView :: (?context :: Request, ?modelContext :: ModelContext) => job -> IO SomeView + makeDetailView :: (?request :: Request, ?modelContext :: ModelContext) => job -> IO SomeView makeDetailView job = do pure $ SomeView $ HtmlView $ renderBaseJobDetailView (buildBaseJob job) -- | The content of the page that will be displayed for the "new job" form of this job. -- By default, only the submit button is rendered. For additonal form data, define your own implementation. -- Can be defined as any arbitrary view, but it should be a form. - makeNewJobView :: (?context :: Request, ?modelContext :: ModelContext) => IO SomeView + makeNewJobView :: (?request :: Request, ?modelContext :: ModelContext) => IO SomeView makeNewJobView = pure $ SomeView $ HtmlView $ renderNewBaseJobForm $ tableName @job -- | The action run to create and insert a new value of this job into the database. -- By default, create an empty record and insert it. -- To add more data, define your own implementation. - createNewJob :: (?context :: Request, ?modelContext :: ModelContext) => IO () + createNewJob :: (?request :: Request, ?modelContext :: ModelContext) => IO () createNewJob = do newRecord @job |> create pure () @@ -112,32 +112,32 @@ class ( job ~ GetModelByTableName (GetTableName job) -- so you'll get a compile error if you try and include a type that is not a job. class JobsDashboard (jobs :: [Type]) where -- | Creates the entire dashboard by recursing on the type list and calling 'makeDashboardSection' on each type. - makeDashboard :: (?context :: Request, ?modelContext :: ModelContext, ?request :: Request) => IO SomeView + makeDashboard :: (?request :: Request, ?modelContext :: ModelContext, ?request :: Request) => IO SomeView includedJobTables :: [Text] -- | Renders the index page, which is the view returned from 'makeDashboard'. - indexPage :: (?context :: Request, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => IO ResponseReceived + indexPage :: (?request :: Request, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => IO ResponseReceived - listJob :: (?context :: Request, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Text -> IO ResponseReceived - listJob' :: (?context :: Request, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Bool -> IO ResponseReceived + listJob :: (?request :: Request, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Text -> IO ResponseReceived + listJob' :: (?request :: Request, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => 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 :: Request, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Text -> UUID -> IO ResponseReceived - viewJob' :: (?context :: Request, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Bool -> IO ResponseReceived + viewJob :: (?request :: Request, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Text -> UUID -> IO ResponseReceived + viewJob' :: (?request :: Request, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => 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 :: Request, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Text -> IO ResponseReceived - newJob' :: (?context :: Request, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Bool -> IO ResponseReceived + newJob :: (?request :: Request, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Text -> IO ResponseReceived + newJob' :: (?request :: Request, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Bool -> IO ResponseReceived -- | Deletes a job from the database. - deleteJob :: (?context :: Request, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Text -> UUID -> IO ResponseReceived - deleteJob' :: (?context :: Request, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Bool -> IO ResponseReceived + deleteJob :: (?request :: Request, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Text -> UUID -> IO ResponseReceived + deleteJob' :: (?request :: Request, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Bool -> IO ResponseReceived - retryJob :: (?context :: Request, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Text -> UUID -> IO ResponseReceived - retryJob' :: (?context :: Request, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => IO ResponseReceived + retryJob :: (?request :: Request, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Text -> UUID -> IO ResponseReceived + retryJob' :: (?request :: Request, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => IO ResponseReceived -- If no types are passed, try to get all tables dynamically and render them as BaseJobs instance JobsDashboard '[] where diff --git a/ihp-job-dashboard/IHP/Job/Dashboard/Auth.hs b/ihp-job-dashboard/IHP/Job/Dashboard/Auth.hs index 0fbffc738..bb2065935 100644 --- a/ihp-job-dashboard/IHP/Job/Dashboard/Auth.hs +++ b/ihp-job-dashboard/IHP/Job/Dashboard/Auth.hs @@ -24,7 +24,7 @@ import qualified IHP.EnvVar as EnvVar -- -- Define your own implementation to use custom authentication for production. class AuthenticationMethod a where - authenticate :: (?context :: Request, ?modelContext :: ModelContext, ?request :: Request, ?respond :: Respond) => IO () + authenticate :: (?request :: Request, ?modelContext :: ModelContext, ?request :: Request, ?respond :: Respond) => IO () -- | Don't use any authentication for jobs. data NoAuth diff --git a/ihp-job-dashboard/IHP/Job/Dashboard/Types.hs b/ihp-job-dashboard/IHP/Job/Dashboard/Types.hs index 60ccb2ebd..637990dd9 100644 --- a/ihp-job-dashboard/IHP/Job/Dashboard/Types.hs +++ b/ihp-job-dashboard/IHP/Job/Dashboard/Types.hs @@ -37,10 +37,10 @@ class TableViewable a where newJobLink :: Html -- | Gets records for displaying in the dashboard index page - getIndex :: (?context :: Request, ?modelContext :: ModelContext) => IO [a] + getIndex :: (?request :: Request, ?modelContext :: ModelContext) => IO [a] -- | Gets paginated records for displaying in the list page - getPage :: (?context :: Request, ?modelContext :: ModelContext) => Int -> Int -> IO [a] + getPage :: (?request :: Request, ?modelContext :: ModelContext) => Int -> Int -> IO [a] -- | Often, jobs are related to some model type. These relations are modeled through the type system. diff --git a/ihp-job-dashboard/IHP/Job/Dashboard/View.hs b/ihp-job-dashboard/IHP/Job/Dashboard/View.hs index 1db23e0a7..259c07880 100644 --- a/ihp-job-dashboard/IHP/Job/Dashboard/View.hs +++ b/ihp-job-dashboard/IHP/Job/Dashboard/View.hs @@ -197,7 +197,7 @@ renderBaseJobDetailView job = let table = job.table in [hsx| -- TABLE VIEWABLE view helpers ----------------------------------- makeDashboardSectionFromTableViewable :: forall a. (TableViewable a - , ?context :: Request + , ?request :: Request , ?modelContext :: ModelContext) => IO SomeView makeDashboardSectionFromTableViewable = do indexRows <- getIndex @a @@ -235,7 +235,7 @@ renderTableViewableTable rows = let -makeListPageFromTableViewable :: forall a. (TableViewable a, ?context :: Request, ?modelContext :: ModelContext) => Int -> Int -> IO SomeView +makeListPageFromTableViewable :: forall a. (TableViewable a, ?request :: Request, ?modelContext :: ModelContext) => Int -> Int -> IO SomeView makeListPageFromTableViewable page pageSize = do pageData <- getPage @a (page - 1) pageSize numPages <- numberOfPagesForTable (modelTableName @a) pageSize diff --git a/ihp-ssc/IHP/ServerSideComponent/Types.hs b/ihp-ssc/IHP/ServerSideComponent/Types.hs index 0a2547a1e..012a06801 100644 --- a/ihp-ssc/IHP/ServerSideComponent/Types.hs +++ b/ihp-ssc/IHP/ServerSideComponent/Types.hs @@ -15,14 +15,14 @@ class Component state action | state -> action where action :: ( ?instanceRef :: IORef (ComponentInstance state) , ?connection :: WebSocket.Connection - , ?context :: Request + , ?request :: Request , ?modelContext :: ModelContext ) => state -> action -> IO state componentDidMount :: ( ?instanceRef :: IORef (ComponentInstance state) , ?connection :: WebSocket.Connection - , ?context :: Request + , ?request :: Request , ?modelContext :: ModelContext ) => state -> IO state componentDidMount state = pure state diff --git a/ihp/IHP/AuthSupport/Controller/Sessions.hs b/ihp/IHP/AuthSupport/Controller/Sessions.hs index 4a028223e..a80196361 100644 --- a/ihp/IHP/AuthSupport/Controller/Sessions.hs +++ b/ihp/IHP/AuthSupport/Controller/Sessions.hs @@ -25,7 +25,7 @@ import IHP.Hasql.FromRow (FromRowHasql) -- In case the user is already logged in, redirects to the home page ('afterLoginRedirectPath'). newSessionAction :: forall record action. ( ?theAction :: action - , ?context :: Request + , ?request :: Request , ?request :: Request , ?respond :: Respond , HasNewSessionUrl record @@ -54,7 +54,7 @@ newSessionAction = do -- After a successful login, the user is redirect to 'afterLoginRedirectPath'. createSessionAction :: forall record action. (?theAction :: action - , ?context :: Request + , ?request :: Request , ?request :: Request , ?respond :: Respond , ?modelContext :: ModelContext @@ -110,7 +110,7 @@ createSessionAction = do -- | Logs out the user and redirects to `afterLogoutRedirectPath` or login page by default deleteSessionAction :: forall record action. ( ?theAction :: action - , ?context :: Request + , ?request :: Request , ?request :: Request , ?respond :: Respond , ?modelContext :: ModelContext @@ -172,13 +172,13 @@ class ( Typeable record -- > unless (user.isConfirmed) do -- > setErrorMessage "Please click the confirmation link we sent to your email before you can use the App" -- > redirectTo NewSessionAction - beforeLogin :: (?context :: Request, ?modelContext :: ModelContext, ?request :: Request) => record -> IO () + beforeLogin :: (?request :: Request, ?modelContext :: ModelContext, ?request :: Request) => record -> IO () beforeLogin _ = pure () -- | Callback that is executed just before the user is logged out -- -- This is called only if user session exists - beforeLogout :: (?context :: Request, ?modelContext :: ModelContext, ?request :: Request) => record -> IO () + beforeLogout :: (?request :: Request, ?modelContext :: ModelContext, ?request :: Request) => record -> IO () beforeLogout _ = pure () -- | Return's the @query\ \@User@ used by the controller. Customize this to e.g. exclude guest users from logging in. diff --git a/ihp/IHP/AutoRefresh.hs b/ihp/IHP/AutoRefresh.hs index 10531509b..29e35e318 100644 --- a/ihp/IHP/AutoRefresh.hs +++ b/ihp/IHP/AutoRefresh.hs @@ -50,7 +50,7 @@ autoRefresh :: ( ?theAction :: action , Controller action , ?modelContext :: ModelContext - , ?context :: Request + , ?request :: Request , ?request :: Request , ?respond :: Respond ) => ((?modelContext :: ModelContext, ?respond :: Respond) => IO ResponseReceived) -> IO ResponseReceived @@ -82,11 +82,10 @@ autoRefresh runAction = do -- messages, framework config, ...) so passing the closure-captured -- values back into the renderView callback is enough. let originalRequest = ?request - let originalContext = ?context let renderView = \waiRequest waiRespond -> do earlyReturnMiddleware (\_ respond -> do - let ?context = originalContext let ?request = originalRequest + let ?context = ?request let ?respond = respond action ?theAction ) waiRequest waiRespond @@ -121,6 +120,7 @@ instance WSApp AutoRefreshWSApp where initialState = AwaitingSessionID run = do + let ?context = ?request sessionId <- receiveData @UUID setState AutoRefreshActive { sessionId } @@ -186,7 +186,7 @@ captureResponseBody originalRespond action = do captured <- readIORef bodyRef pure (result, captured) -registerNotificationTrigger :: (?modelContext :: ModelContext, ?context :: Request) => IORef (Set Text) -> IORef AutoRefreshServer -> IO () +registerNotificationTrigger :: (?modelContext :: ModelContext, ?request :: Request) => IORef (Set Text) -> IORef AutoRefreshServer -> IO () registerNotificationTrigger touchedTablesVar autoRefreshServer = do touchedTables <- Set.toList <$> readIORef touchedTablesVar subscribedTables <- (.subscribedTables) <$> (autoRefreshServer |> readIORef) @@ -197,7 +197,7 @@ registerNotificationTrigger touchedTablesVar autoRefreshServer = do -- `make db` drops and recreates the database, destroying triggers that were -- previously installed. The trigger SQL is idempotent so re-running is safe. -- In production, only install triggers for newly seen tables. - let isDevelopment = ?context.frameworkConfig.environment == Development + let isDevelopment = ?request.frameworkConfig.environment == Development modifyIORef' autoRefreshServer (\server -> server { subscribedTables = server.subscribedTables <> Set.fromList subscriptionRequired }) diff --git a/ihp/IHP/AutoRefresh/View.hs b/ihp/IHP/AutoRefresh/View.hs index 5acb18531..b8b487781 100644 --- a/ihp/IHP/AutoRefresh/View.hs +++ b/ihp/IHP/AutoRefresh/View.hs @@ -8,8 +8,8 @@ import IHP.AutoRefresh (autoRefreshStateVaultKey) import qualified Data.Vault.Lazy as Vault import Network.Wai (Request, vault) -autoRefreshMeta :: (?context :: Request) => Html +autoRefreshMeta :: (?request :: Request) => Html autoRefreshMeta = - case Vault.lookup autoRefreshStateVaultKey ?context.vault of + case Vault.lookup autoRefreshStateVaultKey (vault ?request) of Just (AutoRefreshEnabled { sessionId }) -> [hsx||] _ -> mempty diff --git a/ihp/IHP/ErrorController.hs b/ihp/IHP/ErrorController.hs index f3e2b4c51..e4d3db9c2 100644 --- a/ihp/IHP/ErrorController.hs +++ b/ihp/IHP/ErrorController.hs @@ -152,8 +152,9 @@ displayException exception action additionalInfo = do -- -- In dev mode the action and exception is added to the output. -- In production mode nothing is specific is communicated about the exception -genericHandler :: (Show controller, ?context :: Request, ?respond :: Respond) => Exception.SomeException -> controller -> Text -> IO ResponseReceived +genericHandler :: (Show controller, ?request :: Request, ?respond :: Respond) => Exception.SomeException -> controller -> Text -> IO ResponseReceived genericHandler exception controller additionalInfo = do + let ?context = ?request let errorMessageText = "An exception was raised while running the action " <> tshow controller <> additionalInfo let errorMessageTitle = Exception.displayException exception @@ -171,8 +172,9 @@ genericHandler exception controller additionalInfo = do ?respond $ responseBuilder status500 [(hContentType, "text/html")] ((renderError ?context.frameworkConfig.environment errorTitle errorMessage) |> getBuilder) -postgresHandler :: (Show controller, ?context :: Request, ?respond :: Respond) => SomeException -> controller -> Text -> Maybe (IO ResponseReceived) +postgresHandler :: (Show controller, ?request :: Request, ?respond :: Respond) => SomeException -> controller -> Text -> Maybe (IO ResponseReceived) postgresHandler exception controller additionalInfo = do + let ?context = ?request let handlePostgresOutdatedError :: Text -> Markup -> IO ResponseReceived handlePostgresOutdatedError errorDetail errorText = do @@ -262,7 +264,7 @@ postgresHandler exception controller additionalInfo = do ?respond $ responseBuilder status500 [(hContentType, "text/html")] ((renderError Environment.Development title errorMessage) |> getBuilder) Nothing -> Nothing -patternMatchFailureHandler :: (Show controller, ?context :: Request, ?respond :: Respond) => SomeException -> controller -> Text -> Maybe (IO ResponseReceived) +patternMatchFailureHandler :: (Show controller, ?request :: Request, ?respond :: Respond) => SomeException -> controller -> Text -> Maybe (IO ResponseReceived) patternMatchFailureHandler exception controller additionalInfo = do case fromException exception of Just (exception :: Exception.PatternMatchFail) -> Just do @@ -351,7 +353,7 @@ paramNotFoundExceptionHandler exception controller additionalInfo = do -- Handler for 'IHP.ModelSupport.RecordNotFoundException' -- -- Used only in development mode of the app. -recordNotFoundExceptionHandlerDev :: (Show controller, ?context :: Request, ?respond :: Respond) => SomeException -> controller -> Text -> Maybe (IO ResponseReceived) +recordNotFoundExceptionHandlerDev :: (Show controller, ?request :: Request, ?respond :: Respond) => SomeException -> controller -> Text -> Maybe (IO ResponseReceived) recordNotFoundExceptionHandlerDev exception controller additionalInfo = case fromException exception of Just (exception@(ModelSupport.RecordNotFoundException { queryAndParams })) -> Just do diff --git a/ihp/IHP/FileStorage/ControllerFunctions.hs b/ihp/IHP/FileStorage/ControllerFunctions.hs index ac1f56993..e0a57e179 100644 --- a/ihp/IHP/FileStorage/ControllerFunctions.hs +++ b/ihp/IHP/FileStorage/ControllerFunctions.hs @@ -339,8 +339,7 @@ contentDispositionAttachmentAndFileName fileInfo = -- > redirectTo EditCompanyAction { .. } -- uploadToStorageWithOptions :: forall (fieldName :: Symbol) record (tableName :: Symbol). ( - ?context :: Request - , ?request :: Request + ?request :: Request , SetField fieldName record (Maybe Text) , KnownSymbol fieldName , HasField "id" record (ModelSupport.Id (ModelSupport.NormalizeModel record)) @@ -351,6 +350,7 @@ uploadToStorageWithOptions :: forall (fieldName :: Symbol) record (tableName :: , SetField "meta" record MetaBag ) => StoreFileOptions -> Proxy fieldName -> record -> IO record uploadToStorageWithOptions options field record = do + let ?context = ?request let fieldName :: ByteString = cs (symbolVal (Proxy @fieldName)) let tableName :: Text = cs (symbolVal (Proxy @tableName)) let directory = tableName <> "/" <> cs fieldName @@ -389,7 +389,7 @@ uploadToStorageWithOptions options field record = do -- > redirectTo EditCompanyAction { .. } -- uploadToStorage :: forall (fieldName :: Symbol) record (tableName :: Symbol). ( - ?context :: Request + ?request :: Request , ?request :: Request , SetField fieldName record (Maybe Text) , KnownSymbol fieldName @@ -433,7 +433,9 @@ storage = ?context.frameworkConfig.appConfig |> fromMaybe (error "Could not find FileStorage in config. Did you call initS3Storage from your Config.hs?") -- | Returns the prefix for the storage. This is either @static/@ or an empty string depending on the storage. -storagePrefix :: (?context :: Request) => Text -storagePrefix = case storage of - StaticDirStorage { directory } -> directory - S3Storage { baseUrl} -> baseUrl +storagePrefix :: (?request :: Request) => Text +storagePrefix = + let ?context = ?request + in case storage of + StaticDirStorage { directory } -> directory + S3Storage { baseUrl} -> baseUrl diff --git a/ihp/IHP/LoginSupport/Helper/Controller.hs b/ihp/IHP/LoginSupport/Helper/Controller.hs index 4cb73aab6..3520a1cb1 100644 --- a/ihp/IHP/LoginSupport/Helper/Controller.hs +++ b/ihp/IHP/LoginSupport/Helper/Controller.hs @@ -175,14 +175,13 @@ redirectToLogin newSessionPath = unsafePerformIO $ do -- > projects <- query @Project |> fetch -- enableRowLevelSecurityIfLoggedIn :: - ( ?context :: Request - , ?request :: Request + ( ?request :: Request , ModelSupport.PrimaryKey (ModelSupport.GetTableName CurrentUserRecord) ~ UUID ) => IO () enableRowLevelSecurityIfLoggedIn = do case currentUserIdOrNothing of Just userId -> do - let rlsAuthenticatedRole = ?context.frameworkConfig.rlsAuthenticatedRole + let rlsAuthenticatedRole = ?request.frameworkConfig.rlsAuthenticatedRole let rlsUserId = tshow userId let rlsContext = ModelSupport.RowLevelSecurityContext { rlsAuthenticatedRole, rlsUserId} writeIORef (lookupRequestVault rlsContextVaultKey ?request) (Just rlsContext) diff --git a/ihp/IHP/Pagination/ControllerFunctions.hs b/ihp/IHP/Pagination/ControllerFunctions.hs index 186706143..19dd07abe 100644 --- a/ihp/IHP/Pagination/ControllerFunctions.hs +++ b/ihp/IHP/Pagination/ControllerFunctions.hs @@ -49,7 +49,7 @@ import Data.Text.Encoding (encodeUtf8) -- > user <- userQ |> fetch -- > render IndexView { .. } paginate :: forall controller table . - (?context::Request + (?request::Request , ?modelContext :: ModelContext , ?theAction :: controller , ?request :: Request @@ -80,7 +80,7 @@ paginate = paginateWithOptions defaultPaginationOptions -- > user <- userQ |> fetch -- > render IndexView { .. } paginateWithOptions :: forall controller table . - (?context::Request + (?request::Request , ?modelContext :: ModelContext , ?theAction :: controller , ?request :: Request @@ -123,7 +123,7 @@ paginateWithOptions options query = do -- > user <- userQ |> fetch -- > render IndexView { .. } filterList :: forall name table model . - (?context::Request + (?request::Request , ?request :: Request , KnownSymbol name , HasField name model Text @@ -178,7 +178,7 @@ defaultPaginationOptions = paginatedSqlQuery :: ( FromRowHasql model , ToSnippetParams parameters - , ?context :: Request + , ?request :: Request , ?modelContext :: ModelContext , ?request :: Request ) @@ -202,7 +202,7 @@ paginatedSqlQuery = paginatedSqlQueryWithOptions defaultPaginationOptions paginatedSqlQueryWithOptions :: ( FromRowHasql model , ToSnippetParams parameters - , ?context :: Request + , ?request :: Request , ?modelContext :: ModelContext , ?request :: Request ) diff --git a/ihp/IHP/Pagination/ViewFunctions.hs b/ihp/IHP/Pagination/ViewFunctions.hs index 0c9a85913..b800f1e3a 100644 --- a/ihp/IHP/Pagination/ViewFunctions.hs +++ b/ihp/IHP/Pagination/ViewFunctions.hs @@ -136,7 +136,7 @@ renderPagination pagination@Pagination {currentPage, window, pageSize} = -- -- -- -renderFilter :: (?context::Request, ?request :: Request) => +renderFilter :: (?request :: Request) => Text -- ^ Placeholder text for the text box -> Html renderFilter placeholder = diff --git a/ihp/IHP/View/Form/FormFor.hs b/ihp/IHP/View/Form/FormFor.hs index 1eef498d4..0ac59f1da 100644 --- a/ihp/IHP/View/Form/FormFor.hs +++ b/ihp/IHP/View/Form/FormFor.hs @@ -88,11 +88,11 @@ import IHP.HSX.Markup (Markup, ToHtml(..)) -- >
This field cannot be empty
-- > formFor :: forall record. ( - ?context :: Request + ?request :: Request , ?request :: Request , ModelFormAction record , HasField "meta" record MetaBag - ) => record -> ((?context :: Request, ?formContext :: FormContext record) => Markup) -> Markup + ) => record -> ((?request :: Request, ?formContext :: FormContext record) => Markup) -> Markup formFor record formBody = formForWithOptions @record record (\c -> c) formBody {-# INLINE formFor #-} @@ -113,11 +113,11 @@ formFor record formBody = formForWithOptions @record record (\c -> c) formBody -- > |> set #customFormAttributes [("data-post-id", show formContext.model.id)] -- formForWithOptions :: forall record. ( - ?context :: Request + ?request :: Request , ?request :: Request , ModelFormAction record , HasField "meta" record MetaBag - ) => record -> (FormContext record -> FormContext record) -> ((?context :: Request, ?formContext :: FormContext record) => Markup) -> Markup + ) => record -> (FormContext record -> FormContext record) -> ((?request :: Request, ?formContext :: FormContext record) => Markup) -> Markup formForWithOptions record applyOptions formBody = buildForm (applyOptions (createFormContext record) { formAction = modelFormAction record }) formBody {-# INLINE formForWithOptions #-} @@ -147,11 +147,11 @@ formForWithOptions record applyOptions formBody = buildForm (applyOptions (creat -- > |> set #disableJavascriptSubmission True -- formForWithoutJavascript :: forall record. ( - ?context :: Request + ?request :: Request , ?request :: Request , ModelFormAction record , HasField "meta" record MetaBag - ) => record -> ((?context :: Request, ?formContext :: FormContext record) => Markup) -> Markup + ) => record -> ((?request :: Request, ?formContext :: FormContext record) => Markup) -> Markup formForWithoutJavascript record formBody = formForWithOptions @record record (\formContext -> formContext { disableJavascriptSubmission = True }) formBody {-# INLINE formForWithoutJavascript #-} @@ -179,10 +179,10 @@ formForWithoutJavascript record formBody = formForWithOptions @record record (\f -- > renderForm post = formFor' post (pathTo CreateDraftAction) [hsx||] -- formFor' :: forall record. ( - ?context :: Request + ?request :: Request , ?request :: Request , HasField "meta" record MetaBag - ) => record -> Text -> ((?context :: Request, ?formContext :: FormContext record) => Markup) -> Markup + ) => record -> Text -> ((?request :: Request, ?formContext :: FormContext record) => Markup) -> Markup formFor' record action = buildForm (createFormContext record) { formAction = action } {-# INLINE formFor' #-} @@ -206,7 +206,7 @@ createFormContext record = {-# INLINE createFormContext #-} -- | Used by 'formFor' to render the form -buildForm :: forall model. (?context :: Request) => FormContext model -> ((?context :: Request, ?formContext :: FormContext model) => Markup) -> Markup +buildForm :: forall model. (?request :: Request) => FormContext model -> ((?request :: Request, ?formContext :: FormContext model) => Markup) -> Markup buildForm formContext inner = [hsx| Proxy fieldName -> ((?context :: Request, ?formContext :: FormContext childRecord) => Markup) -> Markup + ) => Proxy fieldName -> ((?request :: Request, ?formContext :: FormContext childRecord) => Markup) -> Markup nestedFormFor field nestedRenderForm = forEach children renderChild where parentFormContext :: FormContext parentRecord diff --git a/ihp/IHP/ViewSupport.hs b/ihp/IHP/ViewSupport.hs index 418c2ed8b..8e840232b 100644 --- a/ihp/IHP/ViewSupport.hs +++ b/ihp/IHP/ViewSupport.hs @@ -57,7 +57,7 @@ import IHP.ActionType (isActiveController) class View theView where -- | Hook which is called before the render is called - beforeRender :: (?request :: Request) => theView -> IO () + beforeRender :: (?context :: Request, ?request :: Request) => theView -> IO () beforeRender view = pure () -- Renders the view as html diff --git a/ihp/IHP/WebSocket.hs b/ihp/IHP/WebSocket.hs index 8f9296785..f1856a730 100644 --- a/ihp/IHP/WebSocket.hs +++ b/ihp/IHP/WebSocket.hs @@ -33,13 +33,13 @@ import qualified Network.WebSockets.Connection as WebSocket class WSApp state where initialState :: state - run :: (?state :: IORef state, ?context :: Request, ?modelContext :: ModelContext, ?connection :: Websocket.Connection, ?request :: Request) => IO () + run :: (?state :: IORef state, ?request :: Request, ?modelContext :: ModelContext, ?connection :: Websocket.Connection, ?request :: Request) => IO () run = pure () - onPing :: (?state :: IORef state, ?context :: Request, ?modelContext :: ModelContext, ?request :: Request) => IO () + onPing :: (?state :: IORef state, ?request :: Request, ?modelContext :: ModelContext, ?request :: Request) => IO () onPing = pure () - onClose :: (?state :: IORef state, ?context :: Request, ?modelContext :: ModelContext, ?connection :: Websocket.Connection, ?request :: Request) => IO () + onClose :: (?state :: IORef state, ?request :: Request, ?modelContext :: ModelContext, ?connection :: Websocket.Connection, ?request :: Request) => IO () onClose = pure () -- | Provide WebSocket Connection Options @@ -59,11 +59,11 @@ class WSApp state where connectionOptions :: WebSocket.ConnectionOptions connectionOptions = WebSocket.defaultConnectionOptions -startWSApp :: forall state. (WSApp state, ?context :: Request, ?modelContext :: ModelContext) => state -> Websocket.Connection -> IO () +startWSApp :: forall state. (WSApp state, ?request :: Request, ?modelContext :: ModelContext) => state -> Websocket.Connection -> IO () startWSApp initialState connection = do state <- newIORef initialState let ?state = state - let ?request = ?context + let ?context = ?request result <- Exception.try ((withPingPong (defaultPingPongOptions { Websocket.pingAction = onPing @state }) connection (\connection -> let ?connection = connection in run @state)) `Exception.finally` (let ?connection = connection in onClose @state)) case result of From a4f37bbbbf75d0d1ccc9f933fcda2c65d7602181 Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Tue, 14 Apr 2026 12:03:55 +0200 Subject: [PATCH 22/27] Fix ihp-job-dashboard build: shim ?context in buildBaseJobTable, dedupe constraints CI on the merged branch failed because buildBaseJobTable lost ?context in its signature but its body calls renderBaseJobTable which still needs it. Add the standard 'let ?context = ?request' shim. Also dedupe (?request :: Request, ?modelContext, ?request :: Request) patterns left over from the bulk rename across ihp-job-dashboard. Co-Authored-By: Claude Opus 4.6 (1M context) --- .../IDE/SchemaDesigner/Controller/Helper.hs | 4 +-- ihp-job-dashboard/IHP/Job/Dashboard.hs | 25 ++++++++++--------- ihp-job-dashboard/IHP/Job/Dashboard/Auth.hs | 2 +- ihp/IHP/AuthSupport/Controller/Sessions.hs | 4 +-- 4 files changed, 17 insertions(+), 18 deletions(-) diff --git a/ihp-ide/IHP/IDE/SchemaDesigner/Controller/Helper.hs b/ihp-ide/IHP/IDE/SchemaDesigner/Controller/Helper.hs index daaaa11d2..8f696b622 100644 --- a/ihp-ide/IHP/IDE/SchemaDesigner/Controller/Helper.hs +++ b/ihp-ide/IHP/IDE/SchemaDesigner/Controller/Helper.hs @@ -41,11 +41,9 @@ getSqlError = SchemaDesignerParser.parseSchemaSql >>= \case Right statements -> do pure Nothing updateSchema :: - ( ?request :: Request - , ?modelContext::ModelContext + (?request :: Request, ?modelContext::ModelContext , ?theAction::controller , ?respond::Respond - , ?request :: Request ) => ([Statement] -> [Statement]) -> IO () updateSchema updateFn = do statements <- readSchema diff --git a/ihp-job-dashboard/IHP/Job/Dashboard.hs b/ihp-job-dashboard/IHP/Job/Dashboard.hs index cb7206005..8c30325e6 100644 --- a/ihp-job-dashboard/IHP/Job/Dashboard.hs +++ b/ihp-job-dashboard/IHP/Job/Dashboard.hs @@ -112,32 +112,32 @@ class ( job ~ GetModelByTableName (GetTableName job) -- so you'll get a compile error if you try and include a type that is not a job. class JobsDashboard (jobs :: [Type]) where -- | Creates the entire dashboard by recursing on the type list and calling 'makeDashboardSection' on each type. - makeDashboard :: (?request :: Request, ?modelContext :: ModelContext, ?request :: Request) => IO SomeView + makeDashboard :: (?request :: Request, ?modelContext :: ModelContext) => IO SomeView includedJobTables :: [Text] -- | Renders the index page, which is the view returned from 'makeDashboard'. - indexPage :: (?request :: Request, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => IO ResponseReceived + indexPage :: (?request :: Request, ?modelContext :: ModelContext, ?respond :: Respond) => IO ResponseReceived - listJob :: (?request :: Request, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Text -> IO ResponseReceived - listJob' :: (?request :: Request, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Bool -> IO ResponseReceived + listJob :: (?request :: Request, ?modelContext :: ModelContext, ?respond :: Respond) => Text -> IO ResponseReceived + listJob' :: (?request :: Request, ?modelContext :: ModelContext, ?respond :: Respond) => 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 :: (?request :: Request, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Text -> UUID -> IO ResponseReceived - viewJob' :: (?request :: Request, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Bool -> IO ResponseReceived + viewJob :: (?request :: Request, ?modelContext :: ModelContext, ?respond :: Respond) => Text -> UUID -> IO ResponseReceived + viewJob' :: (?request :: Request, ?modelContext :: ModelContext, ?respond :: Respond) => 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 :: (?request :: Request, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Text -> IO ResponseReceived - newJob' :: (?request :: Request, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Bool -> IO ResponseReceived + newJob :: (?request :: Request, ?modelContext :: ModelContext, ?respond :: Respond) => Text -> IO ResponseReceived + newJob' :: (?request :: Request, ?modelContext :: ModelContext, ?respond :: Respond) => Bool -> IO ResponseReceived -- | Deletes a job from the database. - deleteJob :: (?request :: Request, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Text -> UUID -> IO ResponseReceived - deleteJob' :: (?request :: Request, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Bool -> IO ResponseReceived + deleteJob :: (?request :: Request, ?modelContext :: ModelContext, ?respond :: Respond) => Text -> UUID -> IO ResponseReceived + deleteJob' :: (?request :: Request, ?modelContext :: ModelContext, ?respond :: Respond) => Bool -> IO ResponseReceived - retryJob :: (?request :: Request, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => Text -> UUID -> IO ResponseReceived - retryJob' :: (?request :: Request, ?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => IO ResponseReceived + retryJob :: (?request :: Request, ?modelContext :: ModelContext, ?respond :: Respond) => Text -> UUID -> IO ResponseReceived + retryJob' :: (?request :: Request, ?modelContext :: ModelContext, ?respond :: Respond) => IO ResponseReceived -- If no types are passed, try to get all tables dynamically and render them as BaseJobs instance JobsDashboard '[] where @@ -377,6 +377,7 @@ getNotIncludedTableNames includedNames = sqlQueryHasql getHasqlPool buildBaseJobTable :: (?modelContext :: ModelContext, ?request :: Request) => Text -> IO SomeView buildBaseJobTable tableName = do + let ?context = ?request baseJobs <- sqlQueryHasql getHasqlPool (Snippet.sql "SELECT " <> Snippet.param tableName <> Snippet.sql ", id, status, updated_at, created_at, last_error FROM " <> sqlIdentifier tableName <> Snippet.sql " ORDER BY created_at DESC LIMIT 10") diff --git a/ihp-job-dashboard/IHP/Job/Dashboard/Auth.hs b/ihp-job-dashboard/IHP/Job/Dashboard/Auth.hs index bb2065935..72b7c26e9 100644 --- a/ihp-job-dashboard/IHP/Job/Dashboard/Auth.hs +++ b/ihp-job-dashboard/IHP/Job/Dashboard/Auth.hs @@ -24,7 +24,7 @@ import qualified IHP.EnvVar as EnvVar -- -- Define your own implementation to use custom authentication for production. class AuthenticationMethod a where - authenticate :: (?request :: Request, ?modelContext :: ModelContext, ?request :: Request, ?respond :: Respond) => IO () + authenticate :: (?request :: Request, ?modelContext :: ModelContext, ?respond :: Respond) => IO () -- | Don't use any authentication for jobs. data NoAuth diff --git a/ihp/IHP/AuthSupport/Controller/Sessions.hs b/ihp/IHP/AuthSupport/Controller/Sessions.hs index a80196361..1a4f4900f 100644 --- a/ihp/IHP/AuthSupport/Controller/Sessions.hs +++ b/ihp/IHP/AuthSupport/Controller/Sessions.hs @@ -172,13 +172,13 @@ class ( Typeable record -- > unless (user.isConfirmed) do -- > setErrorMessage "Please click the confirmation link we sent to your email before you can use the App" -- > redirectTo NewSessionAction - beforeLogin :: (?request :: Request, ?modelContext :: ModelContext, ?request :: Request) => record -> IO () + beforeLogin :: (?request :: Request, ?modelContext :: ModelContext) => record -> IO () beforeLogin _ = pure () -- | Callback that is executed just before the user is logged out -- -- This is called only if user session exists - beforeLogout :: (?request :: Request, ?modelContext :: ModelContext, ?request :: Request) => record -> IO () + beforeLogout :: (?request :: Request, ?modelContext :: ModelContext) => record -> IO () beforeLogout _ = pure () -- | Return's the @query\ \@User@ used by the controller. Customize this to e.g. exclude guest users from logging in. From 76e8e5805ee66e96bb0010f062f8d33fc8eb9c66 Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Tue, 14 Apr 2026 12:13:30 +0200 Subject: [PATCH 23/27] Restore ?context :: Request on RLS DataSync helpers setRLSConfigSession / sqlQueryWithRLSSession / sqlExecWithRLSSession and friends call Role.authenticatedRole, which is polymorphic on ?context :: context with ConfigProvider. Their bodies use a where clause, so a let-shim doesn't reach. Putting ?context :: Request back in the constraint list is the cleanest fix. Co-Authored-By: Claude Opus 4.6 (1M context) --- ihp-datasync/IHP/DataSync/ControllerImpl.hs | 6 +++--- ihp-datasync/IHP/DataSync/RowLevelSecurity.hs | 18 +++++++++--------- 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/ihp-datasync/IHP/DataSync/ControllerImpl.hs b/ihp-datasync/IHP/DataSync/ControllerImpl.hs index a260c8875..61699ea70 100644 --- a/ihp-datasync/IHP/DataSync/ControllerImpl.hs +++ b/ihp-datasync/IHP/DataSync/ControllerImpl.hs @@ -504,7 +504,7 @@ encodePatchToSetSql ren columnTypes patch = in mconcat $ List.intersperse (Snippet.sql ", ") setSnippets sqlQueryWithRLSAndTransactionId :: - ( ?request :: Request + ( ?context :: Request , ?request :: Request , Show (PrimaryKey (GetTableName CurrentUserRecord)) , HasNewSessionUrl CurrentUserRecord @@ -524,7 +524,7 @@ sqlQueryWithRLSAndTransactionId pool Nothing statement = runSession pool (sqlQue -- Use this for INSERT, UPDATE, or DELETE statements with RETURNING that need -- to return results (e.g. wrapped with 'wrapDynamicQuery'). sqlQueryWriteWithRLSAndTransactionId :: - ( ?request :: Request + ( ?context :: Request , ?request :: Request , Show (PrimaryKey (GetTableName CurrentUserRecord)) , HasNewSessionUrl CurrentUserRecord @@ -540,7 +540,7 @@ sqlQueryWriteWithRLSAndTransactionId _pool (Just transactionId) statement = do sqlQueryWriteWithRLSAndTransactionId pool Nothing statement = runSession pool (sqlQueryWriteWithRLSSession statement) sqlExecWithRLSAndTransactionId :: - ( ?request :: Request + ( ?context :: Request , ?request :: Request , Show (PrimaryKey (GetTableName CurrentUserRecord)) , HasNewSessionUrl CurrentUserRecord diff --git a/ihp-datasync/IHP/DataSync/RowLevelSecurity.hs b/ihp-datasync/IHP/DataSync/RowLevelSecurity.hs index ee5215dae..a759b76ab 100644 --- a/ihp-datasync/IHP/DataSync/RowLevelSecurity.hs +++ b/ihp-datasync/IHP/DataSync/RowLevelSecurity.hs @@ -57,7 +57,7 @@ ensureRLSEnabledSession table = do -- This is a Session-level action for use in user-managed transactions -- (e.g. after a manual @BEGIN@). setRLSConfigSession :: - ( ?request :: Request + ( ?context :: Request , ?request :: Request , Show (PrimaryKey (GetTableName CurrentUserRecord)) , HasNewSessionUrl CurrentUserRecord @@ -71,7 +71,7 @@ setRLSConfigSession = Session.statement (Role.authenticatedRole, encodedUserId) Nothing -> "" sqlQueryWithRLSSession :: - ( ?request :: Request + ( ?context :: Request , ?request :: Request , Show (PrimaryKey (GetTableName CurrentUserRecord)) , HasNewSessionUrl CurrentUserRecord @@ -93,7 +93,7 @@ sqlQueryWithRLSSession statement = -- Use this for INSERT, UPDATE, or DELETE statements with RETURNING that need -- to return results (e.g. wrapped with 'wrapDynamicQuery'). sqlQueryWriteWithRLSSession :: - ( ?request :: Request + ( ?context :: Request , ?request :: Request , Show (PrimaryKey (GetTableName CurrentUserRecord)) , HasNewSessionUrl CurrentUserRecord @@ -111,7 +111,7 @@ sqlQueryWriteWithRLSSession statement = {-# INLINE sqlQueryWriteWithRLSSession #-} sqlExecWithRLSSession :: - ( ?request :: Request + ( ?context :: Request , ?request :: Request , Show (PrimaryKey (GetTableName CurrentUserRecord)) , HasNewSessionUrl CurrentUserRecord @@ -129,7 +129,7 @@ sqlExecWithRLSSession statement = {-# INLINE sqlExecWithRLSSession #-} sqlQueryScalarWithRLSSession :: - ( ?request :: Request + ( ?context :: Request , ?request :: Request , Show (PrimaryKey (GetTableName CurrentUserRecord)) , HasNewSessionUrl CurrentUserRecord @@ -149,7 +149,7 @@ sqlQueryScalarWithRLSSession statement = -- IO API (thin wrappers) sqlQueryWithRLS :: - ( ?request :: Request + ( ?context :: Request , ?request :: Request , Show (PrimaryKey (GetTableName CurrentUserRecord)) , HasNewSessionUrl CurrentUserRecord @@ -164,7 +164,7 @@ sqlQueryWithRLS pool statement = runSession pool (sqlQueryWithRLSSession stateme -- Use this for INSERT, UPDATE, or DELETE statements with RETURNING that need -- to return results (e.g. wrapped with 'wrapDynamicQuery'). sqlQueryWriteWithRLS :: - ( ?request :: Request + ( ?context :: Request , ?request :: Request , Show (PrimaryKey (GetTableName CurrentUserRecord)) , HasNewSessionUrl CurrentUserRecord @@ -175,7 +175,7 @@ sqlQueryWriteWithRLS pool statement = runSession pool (sqlQueryWriteWithRLSSessi {-# INLINE sqlQueryWriteWithRLS #-} sqlExecWithRLS :: - ( ?request :: Request + ( ?context :: Request , ?request :: Request , Show (PrimaryKey (GetTableName CurrentUserRecord)) , HasNewSessionUrl CurrentUserRecord @@ -186,7 +186,7 @@ sqlExecWithRLS pool statement = runSession pool (sqlExecWithRLSSession statement {-# INLINE sqlExecWithRLS #-} sqlQueryScalarWithRLS :: - ( ?request :: Request + ( ?context :: Request , ?request :: Request , Show (PrimaryKey (GetTableName CurrentUserRecord)) , HasNewSessionUrl CurrentUserRecord From 7d2573f5b04bafae87d54bf0a9dc94ed36da6722 Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Tue, 14 Apr 2026 12:16:40 +0200 Subject: [PATCH 24/27] Fix more ?context propagation in DataSync ControllerImpl - runDataSyncController: add 'let ?context = ?request' shim - buildMessageHandler: keep ?context :: Request (where bindings need it) - maxTransactions/SubscriptionsPerConnection: shim for getAppConfig (polymorphic ConfigProvider call) Co-Authored-By: Claude Opus 4.6 (1M context) --- ihp-datasync/IHP/DataSync/ControllerImpl.hs | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/ihp-datasync/IHP/DataSync/ControllerImpl.hs b/ihp-datasync/IHP/DataSync/ControllerImpl.hs index 61699ea70..c7ea0a9a6 100644 --- a/ihp-datasync/IHP/DataSync/ControllerImpl.hs +++ b/ihp-datasync/IHP/DataSync/ControllerImpl.hs @@ -43,13 +43,13 @@ runDataSyncController :: ( HasField "id" CurrentUserRecord (Id' (GetTableName CurrentUserRecord)) , ?request :: Request , ?modelContext :: ModelContext - , ?request :: Request , ?state :: IORef DataSyncController , Typeable CurrentUserRecord , HasNewSessionUrl CurrentUserRecord , Show (PrimaryKey (GetTableName CurrentUserRecord)) ) => Hasql.Pool.Pool -> EnsureRLSEnabledFn -> InstallTableChangeTriggerFn -> IO ByteString -> SendJSONFn -> HandleCustomMessageFn -> (Text -> Renamer) -> IO () runDataSyncController hasqlPool ensureRLSEnabled installTableChangeTriggers receiveData sendJSON handleCustomMessage renamer = do + let ?context = ?request setState DataSyncReady { subscriptions = HashMap.empty, transactions = HashMap.empty } columnTypeLookup <- makeCachedColumnTypeLookup hasqlPool @@ -106,9 +106,9 @@ runDataSyncController hasqlPool ensureRLSEnabled installTableChangeTriggers rece buildMessageHandler :: ( HasField "id" CurrentUserRecord (Id' (GetTableName CurrentUserRecord)) + , ?context :: Request , ?request :: Request , ?modelContext :: ModelContext - , ?request :: Request , ?state :: IORef DataSyncController , Typeable CurrentUserRecord , HasNewSessionUrl CurrentUserRecord @@ -481,12 +481,14 @@ ensureBelowSubscriptionsLimit = do maxTransactionsPerConnection :: (?request :: Request) => Int maxTransactionsPerConnection = - case getAppConfig @DataSyncMaxTransactionsPerConnection of + let ?context = ?request + in case getAppConfig @DataSyncMaxTransactionsPerConnection of DataSyncMaxTransactionsPerConnection value -> value maxSubscriptionsPerConnection :: (?request :: Request) => Int maxSubscriptionsPerConnection = - case getAppConfig @DataSyncMaxSubscriptionsPerConnection of + let ?context = ?request + in case getAppConfig @DataSyncMaxSubscriptionsPerConnection of DataSyncMaxSubscriptionsPerConnection value -> value -- | Encode a JSON patch (field name -> value) into a SQL SET clause 'Snippet' like @"col1" = $1, "col2" = $2@. From 20a835bcb19ecb4eece331746eaea2de1149f615 Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Tue, 14 Apr 2026 12:19:02 +0200 Subject: [PATCH 25/27] Shim ?context in DataSync Controller WSApp.run Co-Authored-By: Claude Opus 4.6 (1M context) --- ihp-datasync/IHP/DataSync/Controller.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/ihp-datasync/IHP/DataSync/Controller.hs b/ihp-datasync/IHP/DataSync/Controller.hs index 7b8d50336..e18eb073c 100644 --- a/ihp-datasync/IHP/DataSync/Controller.hs +++ b/ihp-datasync/IHP/DataSync/Controller.hs @@ -18,7 +18,8 @@ instance ( initialState = DataSyncController run = do + let ?context = ?request let hasqlPool = ?modelContext.hasqlPool ensureRLSEnabled <- makeCachedEnsureRLSEnabled hasqlPool - installTableChangeTriggers <- ChangeNotifications.makeInstallTableChangeTriggers ?context.frameworkConfig.environment hasqlPool + installTableChangeTriggers <- ChangeNotifications.makeInstallTableChangeTriggers ?request.frameworkConfig.environment hasqlPool runDataSyncController hasqlPool ensureRLSEnabled installTableChangeTriggers (receiveData @ByteString) sendJSON (\_ _ -> pure ()) (\_ -> camelCaseRenamer) From 800fbd223e4e1e7316f018ec43b43e7f5e5242a0 Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Tue, 14 Apr 2026 12:24:35 +0200 Subject: [PATCH 26/27] Shim ?context in ihp-ssc setState (calls SSC.render which needs ?context) Co-Authored-By: Claude Opus 4.6 (1M context) --- ihp-ssc/IHP/ServerSideComponent/ControllerFunctions.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/ihp-ssc/IHP/ServerSideComponent/ControllerFunctions.hs b/ihp-ssc/IHP/ServerSideComponent/ControllerFunctions.hs index 350e2a315..b004aa9ce 100644 --- a/ihp-ssc/IHP/ServerSideComponent/ControllerFunctions.hs +++ b/ihp-ssc/IHP/ServerSideComponent/ControllerFunctions.hs @@ -28,6 +28,7 @@ $(Aeson.deriveJSON Aeson.defaultOptions { sumEncoding = defaultTaggedObject { ta setState :: (?instanceRef :: IORef (ComponentInstance state), ?connection :: WebSocket.Connection, Component state action, ?request :: Request) => state -> IO () setState state = do + let ?context = ?request oldState <- (.state) <$> readIORef ?instanceRef let oldHtml = oldState |> SSC.render From ebd201d5c971fc298918f3cbcbcb18b55c728b5c Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Tue, 14 Apr 2026 12:26:52 +0200 Subject: [PATCH 27/27] Shim ?context in ihp-ssc ComponentsController.run for Log calls Co-Authored-By: Claude Opus 4.6 (1M context) --- .../IHP/ServerSideComponent/Controller/ComponentsController.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/ihp-ssc/IHP/ServerSideComponent/Controller/ComponentsController.hs b/ihp-ssc/IHP/ServerSideComponent/Controller/ComponentsController.hs index cc0758f27..b15e01123 100644 --- a/ihp-ssc/IHP/ServerSideComponent/Controller/ComponentsController.hs +++ b/ihp-ssc/IHP/ServerSideComponent/Controller/ComponentsController.hs @@ -14,6 +14,7 @@ instance (Component component controller, FromJSON controller, Typeable componen initialState = ComponentsController run = do + let ?context = ?request let state :: component = SSC.initialState instanceRef <- newIORef (ComponentInstance { state }) let ?instanceRef = instanceRef