From 1a37dbe51f01df012962448e36f0aa4673171496 Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Wed, 18 Feb 2026 14:57:21 +0100 Subject: [PATCH 1/6] Extract ihp-auto-refresh into its own package AutoRefresh (automatic diff-based view re-rendering via WebSocket + PostgreSQL LISTEN/NOTIFY) was bundled in the main ihp package. This extracts it into ihp-auto-refresh, making it an opt-in feature that reduces compilation for apps that don't use it, following the pattern of ihp-ssc, ihp-datasync, etc. Key changes: - Create ihp-auto-refresh/ package with cabal, nix, sources, and tests - Remove autoRefreshApp type parameter from frontControllerToWAIApp - Remove AutoRefresh imports from Server.hs, ControllerPrelude, ViewPrelude - Remove AutoRefresh from ToolServer (IDE doesn't need it) - Add ihp-auto-refresh to NixSupport/overlay.nix Apps using AutoRefresh need to: 1. Add ihp-auto-refresh to build-depends 2. Add explicit imports for IHP.AutoRefresh / IHP.AutoRefresh.View 3. Add webSocketApp @AutoRefreshWSApp to FrontController controllers list Co-Authored-By: Claude Opus 4.6 --- NixSupport/overlay.nix | 1 + ihp-auto-refresh/IHP/AutoRefresh.hs | 309 ++++++++++++++++++++++ ihp-auto-refresh/IHP/AutoRefresh/Types.hs | 37 +++ ihp-auto-refresh/IHP/AutoRefresh/View.hs | 16 ++ ihp-auto-refresh/Test/AutoRefreshSpec.hs | 146 ++++++++++ ihp-auto-refresh/Test/Main.hs | 10 + ihp-auto-refresh/default.nix | 19 ++ ihp-auto-refresh/ihp-auto-refresh.cabal | 88 ++++++ ihp-ide/IHP/IDE/ToolServer.hs | 3 +- ihp/IHP/ControllerPrelude.hs | 3 - ihp/IHP/RouterSupport.hs | 4 +- ihp/IHP/Server.hs | 3 +- ihp/IHP/ViewPrelude.hs | 2 - ihp/Test/Test/Main.hs | 2 - ihp/ihp.cabal | 4 - 15 files changed, 630 insertions(+), 17 deletions(-) create mode 100644 ihp-auto-refresh/IHP/AutoRefresh.hs create mode 100644 ihp-auto-refresh/IHP/AutoRefresh/Types.hs create mode 100644 ihp-auto-refresh/IHP/AutoRefresh/View.hs create mode 100644 ihp-auto-refresh/Test/AutoRefreshSpec.hs create mode 100644 ihp-auto-refresh/Test/Main.hs create mode 100644 ihp-auto-refresh/default.nix create mode 100644 ihp-auto-refresh/ihp-auto-refresh.cabal diff --git a/NixSupport/overlay.nix b/NixSupport/overlay.nix index b8d51375f..715e018fa 100644 --- a/NixSupport/overlay.nix +++ b/NixSupport/overlay.nix @@ -49,6 +49,7 @@ let ihp-migrate = (localPackage "ihp-migrate").overrideAttrs (old: { mainProgram = "migrate"; }); ihp-openai = localPackage "ihp-openai"; ihp-postgresql-simple-extra = localPackage "ihp-postgresql-simple-extra"; + ihp-auto-refresh = localPackage "ihp-auto-refresh"; ihp-ssc = localPackage "ihp-ssc"; ihp-zip = fastBuild (super.callCabal2nix "ihp-zip" (final.fetchFromGitHub { owner = "digitallyinduced"; repo = "ihp-zip"; rev = "1c0d812d12d21269f83d6480a6ec7a8cdd054485"; sha256 = "0y0dj8ggi1jqzy74i0d6k9my8kdvfi516zfgnsl7znicwq9laald"; }) {}); ihp-hsx = localPackage "ihp-hsx"; diff --git a/ihp-auto-refresh/IHP/AutoRefresh.hs b/ihp-auto-refresh/IHP/AutoRefresh.hs new file mode 100644 index 000000000..e5f110259 --- /dev/null +++ b/ihp-auto-refresh/IHP/AutoRefresh.hs @@ -0,0 +1,309 @@ +{-| +Module: IHP.AutoRefresh +Description: Provides automatically diff-based refreshing views after page load +Copyright: (c) digitally induced GmbH, 2020 +-} +module IHP.AutoRefresh where + +import IHP.Prelude +import IHP.AutoRefresh.Types +import IHP.ControllerSupport +import qualified Data.UUID.V4 as UUID +import qualified Data.UUID as UUID +import IHP.Controller.Session +import qualified Network.Wai.Internal as Wai +import qualified Data.Binary.Builder as ByteString +import qualified Data.Set as Set +import IHP.ModelSupport +import qualified Control.Exception as Exception +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 IHP.Controller.Response +import qualified IHP.PGListener as PGListener +import qualified Hasql.Session as HasqlSession +import qualified IHP.Log as Log +import qualified Data.Vault.Lazy as Vault +import System.IO.Unsafe (unsafePerformIO) +import Network.Wai +import qualified Data.TMap as TypeMap +import IHP.RequestVault (pgListenerVaultKey) +import IHP.FrameworkConfig.Types (FrameworkConfig(..)) +import IHP.Environment (Environment(..)) + +{-# NOINLINE globalAutoRefreshServerVar #-} +globalAutoRefreshServerVar :: MVar.MVar (Maybe (IORef AutoRefreshServer)) +globalAutoRefreshServerVar = unsafePerformIO (MVar.newMVar Nothing) + +getOrCreateAutoRefreshServer :: (?request :: Request) => IO (IORef AutoRefreshServer) +getOrCreateAutoRefreshServer = + MVar.modifyMVar globalAutoRefreshServerVar $ \case + Just server -> pure (Just server, server) + Nothing -> do + let pgListener = case Vault.lookup pgListenerVaultKey ?request.vault of + Just pl -> pl + Nothing -> error "getOrCreateAutoRefreshServer: PGListener not found in request vault" + server <- newIORef (newAutoRefreshServer pgListener) + pure (Just server, server) + +autoRefresh :: ( + ?theAction :: action + , Controller action + , ?modelContext :: ModelContext + , ?context :: ControllerContext + , ?request :: Request + ) => ((?modelContext :: ModelContext) => IO ()) -> IO () +autoRefresh runAction = do + let autoRefreshState = Vault.lookup autoRefreshStateVaultKey ?request.vault + autoRefreshServer <- getOrCreateAutoRefreshServer + + case autoRefreshState of + Just (AutoRefreshEnabled {}) -> do + -- When this function calls the 'action ?theAction' in the other case + -- we will evaluate this branch + runAction + _ -> do + availableSessions <- getAvailableSessions autoRefreshServer + + id <- UUID.nextRandom + + -- Update the vault with AutoRefreshEnabled so that autoRefreshMeta can read it + let newRequest = ?request { vault = Vault.insert autoRefreshStateVaultKey (AutoRefreshEnabled id) ?request.vault } + let ?request = newRequest + -- Update request in controller context so freeze captures the updated state + let ControllerContext { customFieldsRef } = ?context + modifyIORef' customFieldsRef (TypeMap.insert @Network.Wai.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 + + let originalRequest = ?request + let renderView = \_waiRequest waiRespond -> do + controllerContext <- unfreeze frozenControllerContext + let ?context = controllerContext + let ?request = originalRequest + let ?respond = waiRespond + putContext originalRequest + action ?theAction + + -- We save the allowed session ids to the session cookie to only grant a client access + -- to sessions it initially opened itself + -- + -- Otherwise you might try to guess session UUIDs to access other peoples auto refresh sessions + setSession "autoRefreshSessions" (map UUID.toText (id:availableSessions) |> Text.intercalate "") + + withTableReadTracker do + let handleResponse exception@(ResponseException response) = case response of + Wai.ResponseBuilder status headers builder -> do + tables <- readIORef ?touchedTables + lastPing <- getCurrentTime + + -- It's important that we evaluate the response to HNF here + -- Otherwise a response `error "fail"` will break auto refresh and cause + -- the action to be unreachable until the server is restarted. + -- + -- Specifically a request like this will crash the action: + -- + -- > curl --header 'Accept: application/json' http://localhost:8000/ShowItem?itemId=6bbe1a72-400a-421e-b26a-ff58d17af3e5 + -- + -- Let's assume that the view has no implementation for JSON responses. Then + -- it will render a 'error "JSON not implemented"'. After this curl request + -- all future HTML requests to the current action will fail with a 503. + -- + lastResponse <- Exception.evaluate (ByteString.toLazyByteString builder) + + event <- MVar.newEmptyMVar + let session = AutoRefreshSession { id, renderView, event, tables, lastResponse, lastPing } + modifyIORef' autoRefreshServer (\s -> s { sessions = session:s.sessions } ) + async (gcSessions autoRefreshServer) + + registerNotificationTrigger ?touchedTables autoRefreshServer + + throw exception + _ -> error "Unimplemented WAI response type." + + runAction `Exception.catch` handleResponse + +data AutoRefreshWSApp = AwaitingSessionID | AutoRefreshActive { sessionId :: UUID } +instance WSApp AutoRefreshWSApp where + initialState = AwaitingSessionID + + run = do + sessionId <- receiveData @UUID + setState AutoRefreshActive { sessionId } + + autoRefreshServer <- getOrCreateAutoRefreshServer + availableSessions <- getAvailableSessions autoRefreshServer + + when (sessionId `elem` availableSessions) do + AutoRefreshSession { renderView, event, lastResponse } <- getSessionById autoRefreshServer sessionId + + let handleResponseException (ResponseException response) = case response of + Wai.ResponseBuilder status headers builder -> do + let html = ByteString.toLazyByteString builder + + when (html /= lastResponse) do + sendTextData html + updateSession autoRefreshServer sessionId (\session -> session { lastResponse = html }) + _ -> error "Unimplemented WAI response type." + + let handleOtherException :: SomeException -> IO () + handleOtherException ex = Log.error ("AutoRefresh: Failed to re-render view: " <> tshow ex) + + async $ forever do + MVar.takeMVar event + let currentRequest = ?request + -- Create a dummy respond function that does nothing, since actual response + -- is handled by the handleResponseException handler + let dummyRespond _ = error "AutoRefresh: respond should not be called directly" + ((renderView currentRequest dummyRespond) `catch` handleResponseException) `catch` handleOtherException + pure () + + pure () + + -- Keep the connection open until it's killed and the onClose is called + forever receiveDataMessage + + onPing = do + now <- getCurrentTime + AutoRefreshActive { sessionId } <- getState + autoRefreshServer <- getOrCreateAutoRefreshServer + updateSession autoRefreshServer sessionId (\session -> session { lastPing = now }) + + onClose = do + getState >>= \case + AutoRefreshActive { sessionId } -> do + autoRefreshServer <- getOrCreateAutoRefreshServer + modifyIORef' autoRefreshServer (\server -> server { sessions = filter (\AutoRefreshSession { id } -> id /= sessionId) server.sessions }) + AwaitingSessionID -> pure () + + +registerNotificationTrigger :: (?modelContext :: ModelContext, ?context :: ControllerContext) => IORef (Set Text) -> IORef AutoRefreshServer -> IO () +registerNotificationTrigger touchedTablesVar autoRefreshServer = do + touchedTables <- Set.toList <$> readIORef touchedTablesVar + subscribedTables <- (.subscribedTables) <$> (autoRefreshServer |> readIORef) + + let subscriptionRequired = touchedTables |> filter (\table -> subscribedTables |> Set.notMember table) + + -- In development, always re-run trigger SQL for all touched tables because + -- `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 + + modifyIORef' autoRefreshServer (\server -> server { subscribedTables = server.subscribedTables <> Set.fromList subscriptionRequired }) + + pgListener <- (.pgListener) <$> readIORef autoRefreshServer + subscriptions <- subscriptionRequired |> mapM (\table -> do + -- We need to add the trigger from the main IHP database role other we will get this error: + -- ERROR: permission denied for schema public + withRowLevelSecurityDisabled do + let pool = ?modelContext.hasqlPool + runSessionHasql pool (HasqlSession.script (notificationTriggerSQL table)) + + pgListener |> PGListener.subscribe (channelName table) \notification -> do + sessions <- (.sessions) <$> readIORef autoRefreshServer + sessions + |> filter (\session -> table `Set.member` session.tables) + |> map (\session -> session.event) + |> mapM (\event -> MVar.tryPutMVar event ()) + pure ()) + + -- Re-run trigger SQL for already-subscribed tables in dev mode + when isDevelopment do + let alreadySubscribed = touchedTables |> filter (\table -> subscribedTables |> Set.member table) + forM_ alreadySubscribed \table -> do + withRowLevelSecurityDisabled do + let pool = ?modelContext.hasqlPool + runSessionHasql pool (HasqlSession.script (notificationTriggerSQL table)) + + modifyIORef' autoRefreshServer (\s -> s { subscriptions = s.subscriptions <> subscriptions }) + pure () + +-- | Returns the ids of all sessions available to the client based on what sessions are found in the session cookie +getAvailableSessions :: (?request :: Request) => IORef AutoRefreshServer -> IO [UUID] +getAvailableSessions autoRefreshServer = do + allSessions <- (.sessions) <$> readIORef autoRefreshServer + text <- fromMaybe "" <$> getSession "autoRefreshSessions" + let uuidCharCount = Text.length (UUID.toText UUID.nil) + let allSessionIds = map (.id) allSessions + text + |> Text.chunksOf uuidCharCount + |> mapMaybe UUID.fromText + |> filter (\id -> id `elem` allSessionIds) + |> pure + +-- | Returns a session for a given session id. Errors in case the session does not exist. +getSessionById :: IORef AutoRefreshServer -> UUID -> IO AutoRefreshSession +getSessionById autoRefreshServer sessionId = do + autoRefreshServer <- readIORef autoRefreshServer + autoRefreshServer.sessions + |> find (\AutoRefreshSession { id } -> id == sessionId) + |> Maybe.fromMaybe (error "getSessionById: Could not find the session") + |> pure + +-- | Applies a update function to a session specified by its session id +updateSession :: IORef AutoRefreshServer -> UUID -> (AutoRefreshSession -> AutoRefreshSession) -> IO () +updateSession server sessionId updateFunction = do + let updateSession' session = if session.id == sessionId then updateFunction session else session + modifyIORef' server (\server -> server { sessions = map updateSession' server.sessions }) + pure () + +-- | Removes all expired sessions +-- +-- This is useful to avoid dead sessions hanging around. This can happen when a websocket connection was never established +-- after the initial request. Then the onClose of the websocket app is never called and thus the session will not be +-- removed automatically. +gcSessions :: IORef AutoRefreshServer -> IO () +gcSessions autoRefreshServer = do + now <- getCurrentTime + modifyIORef' autoRefreshServer (\autoRefreshServer -> autoRefreshServer { sessions = filter (not . isSessionExpired now) autoRefreshServer.sessions }) + +-- | A session is expired if it was not pinged in the last 60 seconds +isSessionExpired :: UTCTime -> AutoRefreshSession -> Bool +isSessionExpired now AutoRefreshSession { lastPing } = (now `diffUTCTime` lastPing) > (secondsToNominalDiffTime 60) + +-- | Returns the event name of the event that the pg notify trigger dispatches +channelName :: Text -> ByteString +channelName tableName = "ar_did_change_" <> cs tableName + +-- | Returns a SQL script to set up database notification triggers. +-- +-- Wrapped in a DO $$ block with EXCEPTION handler because concurrent requests +-- can race to CREATE OR REPLACE the same function, causing PostgreSQL to throw +-- 'tuple concurrently updated' (SQLSTATE XX000). This is safe to ignore: the +-- other connection's CREATE OR REPLACE will have succeeded. +notificationTriggerSQL :: Text -> Text +notificationTriggerSQL tableName = + "DO $$\n" + <> "BEGIN\n" + <> " CREATE OR REPLACE FUNCTION " <> functionName <> "() RETURNS TRIGGER AS $BODY$" + <> "BEGIN\n" + <> " PERFORM pg_notify('" <> cs (channelName tableName) <> "', '');\n" + <> " RETURN new;\n" + <> "END;\n" + <> "$BODY$ language plpgsql;\n" + <> " DROP TRIGGER IF EXISTS " <> insertTriggerName <> " ON " <> tableName <> ";\n" + <> " CREATE TRIGGER " <> insertTriggerName <> " AFTER INSERT ON \"" <> tableName <> "\" FOR EACH STATEMENT EXECUTE PROCEDURE " <> functionName <> "();\n" + <> " DROP TRIGGER IF EXISTS " <> updateTriggerName <> " ON " <> tableName <> ";\n" + <> " CREATE TRIGGER " <> updateTriggerName <> " AFTER UPDATE ON \"" <> tableName <> "\" FOR EACH STATEMENT EXECUTE PROCEDURE " <> functionName <> "();\n" + <> " DROP TRIGGER IF EXISTS " <> deleteTriggerName <> " ON " <> tableName <> ";\n" + <> " CREATE TRIGGER " <> deleteTriggerName <> " AFTER DELETE ON \"" <> tableName <> "\" FOR EACH STATEMENT EXECUTE PROCEDURE " <> functionName <> "();\n" + <> "EXCEPTION\n" + <> " WHEN SQLSTATE 'XX000' THEN null; -- 'tuple concurrently updated': another connection installed it first\n" + <> "END; $$" + where + functionName = "ar_notify_did_change_" <> tableName + insertTriggerName = "ar_did_insert_" <> tableName + updateTriggerName = "ar_did_update_" <> tableName + deleteTriggerName = "ar_did_delete_" <> tableName + +autoRefreshStateVaultKey :: Vault.Key AutoRefreshState +autoRefreshStateVaultKey = unsafePerformIO Vault.newKey +{-# NOINLINE autoRefreshStateVaultKey #-} diff --git a/ihp-auto-refresh/IHP/AutoRefresh/Types.hs b/ihp-auto-refresh/IHP/AutoRefresh/Types.hs new file mode 100644 index 000000000..4597a648e --- /dev/null +++ b/ihp-auto-refresh/IHP/AutoRefresh/Types.hs @@ -0,0 +1,37 @@ +{-| +Module: IHP.AutoRefresh.Types +Description: Types & Data Structures for IHP AutoRefresh +Copyright: (c) digitally induced GmbH, 2020 +-} +module IHP.AutoRefresh.Types where + +import IHP.Prelude +import Wai.Request.Params.Middleware (Respond) +import Control.Concurrent.MVar (MVar) +import qualified IHP.PGListener as PGListener +import Network.Wai (Request) + +data AutoRefreshState = AutoRefreshEnabled { sessionId :: !UUID } +data AutoRefreshSession = AutoRefreshSession + { id :: !UUID + -- | A callback to rerun an action within the given request and respond + , renderView :: !(Request -> Respond -> IO ()) + -- | MVar that is filled whenever some table changed + , event :: !(MVar ()) + -- | All tables this auto refresh session watches + , tables :: !(Set Text) + -- | The last rendered html of this action. Initially this is the result of the initial page rendering + , lastResponse :: !LByteString + -- | Keep track of the last ping to this session to close it after too much time has passed without anything happening + , lastPing :: !UTCTime + } + +data AutoRefreshServer = AutoRefreshServer + { subscriptions :: [PGListener.Subscription] + , sessions :: ![AutoRefreshSession] + , subscribedTables :: !(Set Text) + , pgListener :: PGListener.PGListener + } + +newAutoRefreshServer :: PGListener.PGListener -> AutoRefreshServer +newAutoRefreshServer pgListener = AutoRefreshServer { subscriptions = [], sessions = [], subscribedTables = mempty, pgListener } diff --git a/ihp-auto-refresh/IHP/AutoRefresh/View.hs b/ihp-auto-refresh/IHP/AutoRefresh/View.hs new file mode 100644 index 000000000..66ff8d2ac --- /dev/null +++ b/ihp-auto-refresh/IHP/AutoRefresh/View.hs @@ -0,0 +1,16 @@ +module IHP.AutoRefresh.View where + +import IHP.Prelude +import IHP.AutoRefresh.Types +import IHP.HSX.QQ (hsx) +import qualified Text.Blaze.Html5 as Html5 +import IHP.Controller.Context +import IHP.AutoRefresh (autoRefreshStateVaultKey) +import qualified Data.Vault.Lazy as Vault +import Network.Wai (vault) + +autoRefreshMeta :: (?context :: ControllerContext) => Html5.Html +autoRefreshMeta = + case Vault.lookup autoRefreshStateVaultKey ?context.request.vault of + Just (AutoRefreshEnabled { sessionId }) -> [hsx||] + _ -> mempty diff --git a/ihp-auto-refresh/Test/AutoRefreshSpec.hs b/ihp-auto-refresh/Test/AutoRefreshSpec.hs new file mode 100644 index 000000000..cb7010d75 --- /dev/null +++ b/ihp-auto-refresh/Test/AutoRefreshSpec.hs @@ -0,0 +1,146 @@ +{-| +Module: Test.AutoRefreshSpec +Tests that AutoRefresh preserves query parameters when re-rendering +with a bare WebSocket request (no query params). +-} +{-# LANGUAGE AllowAmbiguousTypes #-} + +module Test.AutoRefreshSpec where +import Test.Hspec +import IHP.Prelude +import IHP.Environment +import IHP.FrameworkConfig +import IHP.ControllerPrelude hiding (get, request) +import Network.Wai +import Network.Wai.Internal (ResponseReceived(..)) +import Network.HTTP.Types +import IHP.AutoRefresh (globalAutoRefreshServerVar) +import IHP.AutoRefresh.Types +import qualified Control.Concurrent.MVar as MVar +import IHP.Controller.Response (ResponseException(..)) +import qualified Control.Exception as Exception +import qualified IHP.PGListener as PGListener +import IHP.Log.Types (Logger(..), LogLevel(..)) +import IHP.Server (initMiddlewareStack) +import IHP.Test.Mocking +import qualified Network.Wai as Wai + +data WebApplication = WebApplication deriving (Eq, Show, Data) + +data TestController + = ShowItemAction + deriving (Eq, Show, Data) + +instance Controller TestController where + action ShowItemAction = autoRefresh do + let marketId = param @Text "marketId" + renderPlain (cs marketId) + +instance AutoRoute TestController + +instance FrontController WebApplication where + controllers = [ parseRoute @TestController ] + +instance InitControllerContext WebApplication where + initContext = pure () + +instance FrontController RootApplication where + controllers = [ mountFrontController WebApplication ] + +config :: ConfigBuilder +config = do + option Development + option (AppPort 8000) + +-- | Helper that calls a controller action with query parameters (GET-style) +-- and passes a PGListener to the middleware stack so autoRefresh can work. +callActionWithQueryParams + :: forall application controller + . ( Controller controller + , ContextParameters application + , Typeable application + , Typeable controller + ) + => PGListener.PGListener + -> controller + -> [(ByteString, ByteString)] + -> IO Response +callActionWithQueryParams pgListener controller queryParams = do + let MockContext { frameworkConfig, modelContext } = ?mocking + + -- Build request with query params (GET-style, not POST body) + let baseRequest = ?request + { Wai.queryString = map (\(k,v) -> (k, Just v)) queryParams + , Wai.rawQueryString = renderSimpleQuery True queryParams + } + + -- Capture the response + responseRef <- newIORef Nothing + let captureRespond response = do + writeIORef responseRef (Just response) + pure ResponseReceived + + -- Create the controller app + let controllerApp req respond = do + let ?request = req + let ?respond = respond + runActionWithNewContext controller + + -- Run through middleware stack with PGListener enabled + middlewareStack <- initMiddlewareStack frameworkConfig modelContext (Just pgListener) + _ <- middlewareStack controllerApp baseRequest captureRespond + + readIORef responseRef >>= \case + Just response -> pure response + Nothing -> error "callActionWithQueryParams: No response was returned by the controller" + +testLogger :: Logger +testLogger = Logger + { write = \_ -> pure () + , level = Debug + , formatter = \_ _ msg -> msg + , timeCache = pure "" + , cleanup = pure () + } + +tests :: Spec +tests = beforeAll (mockContextNoDatabase WebApplication config) do + describe "AutoRefresh" do + describe "renderView" do + it "should preserve query parameters when re-rendering with a websocket request" $ withContext do + -- Clean up any leftover global state from previous tests + MVar.modifyMVar_ globalAutoRefreshServerVar (\_ -> pure Nothing) + + PGListener.withPGListener "" testLogger \pgListener -> do + -- 1. Call the action with query params — this triggers autoRefresh + -- which stores a session with renderView + response <- callActionWithQueryParams pgListener ShowItemAction [("marketId", "abc-123")] + body <- responseBody response + cs body `shouldBe` ("abc-123" :: Text) + + -- 2. Extract the stored renderView from the AutoRefreshSession + maybeServerRef <- MVar.readMVar globalAutoRefreshServerVar + serverRef <- case maybeServerRef of + Just ref -> pure ref + Nothing -> error "AutoRefreshServer was not created" + + server <- readIORef serverRef + session <- case server.sessions of + (s:_) -> pure s + [] -> error "No AutoRefresh sessions found" + + -- 3. Call renderView with a bare request (simulating WebSocket re-render) + -- The WebSocket request has NO query params — this is the bug scenario + let bareRequest = defaultRequest + result <- Exception.try $ session.renderView bareRequest (\_ -> error "respond should not be called") + case result of + Left (ResponseException reResponse) -> do + reBody <- responseBody reResponse + -- If query params are NOT preserved, this would throw ParamNotFoundException + -- instead of reaching here with the correct value + cs reBody `shouldBe` ("abc-123" :: Text) + Right _ -> + expectationFailure "renderView should have thrown ResponseException" + + -- Cleanup + MVar.modifyMVar_ globalAutoRefreshServerVar (\_ -> pure Nothing) diff --git a/ihp-auto-refresh/Test/Main.hs b/ihp-auto-refresh/Test/Main.hs new file mode 100644 index 000000000..7e30a7fa5 --- /dev/null +++ b/ihp-auto-refresh/Test/Main.hs @@ -0,0 +1,10 @@ +module Main where + +import Test.Hspec +import IHP.Prelude + +import qualified Test.AutoRefreshSpec + +main :: IO () +main = hspec do + Test.AutoRefreshSpec.tests diff --git a/ihp-auto-refresh/default.nix b/ihp-auto-refresh/default.nix new file mode 100644 index 000000000..bc2aa3a51 --- /dev/null +++ b/ihp-auto-refresh/default.nix @@ -0,0 +1,19 @@ +{ mkDerivation, async, base, basic-prelude, binary, blaze-html +, bytestring, containers, hasql, hasql-dynamic-statements +, hasql-pool, ihp, ihp-context, ihp-hsx, ihp-log, ihp-pglistener +, lib, string-conversions, text, time, uuid, vault, wai +, wai-request-params, websockets +}: +mkDerivation { + pname = "ihp-auto-refresh"; + version = "1.4.0"; + src = ./.; + libraryHaskellDepends = [ + async base basic-prelude binary blaze-html bytestring containers + hasql hasql-dynamic-statements hasql-pool ihp ihp-context ihp-hsx + ihp-log ihp-pglistener string-conversions text time uuid vault wai + wai-request-params websockets + ]; + description = "AutoRefresh for IHP"; + license = lib.licenses.mit; +} diff --git a/ihp-auto-refresh/ihp-auto-refresh.cabal b/ihp-auto-refresh/ihp-auto-refresh.cabal new file mode 100644 index 000000000..d3bc925c8 --- /dev/null +++ b/ihp-auto-refresh/ihp-auto-refresh.cabal @@ -0,0 +1,88 @@ +cabal-version: 2.2 +name: ihp-auto-refresh +version: 1.4.0 +synopsis: AutoRefresh for IHP +description: Provides automatically diff-based refreshing views after page load via WebSocket and PostgreSQL LISTEN/NOTIFY. +license: MIT +author: digitally induced GmbH +maintainer: hello@digitallyinduced.com +build-type: Simple + +common shared-properties + default-language: GHC2021 + default-extensions: + OverloadedStrings + , NoImplicitPrelude + , ImplicitParams + , DisambiguateRecordFields + , DuplicateRecordFields + , OverloadedLabels + , DataKinds + , QuasiQuotes + , TypeFamilies + , PackageImports + , RecordWildCards + , DefaultSignatures + , FunctionalDependencies + , PartialTypeSignatures + , BlockArguments + , LambdaCase + , TemplateHaskell + , OverloadedRecordDot + , DeepSubsumption + 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 + , ihp + , ihp-hsx + , ihp-pglistener + , ihp-log + , ihp-context + , basic-prelude + , string-conversions + , uuid + , vault + , wai + , websockets + , containers + , async + , binary + , time + , hasql + , hasql-pool + , hasql-dynamic-statements + , blaze-html + , text + , bytestring + , wai-request-params + exposed-modules: + IHP.AutoRefresh + , IHP.AutoRefresh.Types + , IHP.AutoRefresh.View + +test-suite tests + import: shared-properties + type: exitcode-stdio-1.0 + main-is: Test/Main.hs + hs-source-dirs: . + ghc-options: -threaded + build-depends: + base >= 4.17.0 && < 4.22 + , ihp + , ihp-auto-refresh + , ihp-pglistener + , ihp-log + , ihp-context + , hspec + , basic-prelude + , string-conversions + , wai + , http-types + , bytestring + , wai-request-params + other-modules: + Test.AutoRefreshSpec diff --git a/ihp-ide/IHP/IDE/ToolServer.hs b/ihp-ide/IHP/IDE/ToolServer.hs index 397e6d53c..57d6f99f5 100644 --- a/ihp-ide/IHP/IDE/ToolServer.hs +++ b/ihp-ide/IHP/IDE/ToolServer.hs @@ -33,7 +33,6 @@ import IHP.IDE.ToolServer.Routes () import qualified System.Process as Process import System.Info import qualified IHP.EnvVar as EnvVar -import qualified IHP.AutoRefresh as AutoRefresh import qualified IHP.IDE.ToolServer.Layout as Layout import IHP.Controller.Layout import qualified IHP.IDE.LiveReloadNotificationServer as LiveReloadNotificationServer @@ -111,7 +110,7 @@ withToolServerApplication toolServerApplication port liveReloadClients action = staticApp <- initStaticApp let innerApplication :: Wai.Application = \request respond -> do - frontControllerToWAIApp @ToolServerApplication @AutoRefresh.AutoRefreshWSApp (\app -> app) toolServerApplication staticApp request respond + frontControllerToWAIApp @ToolServerApplication (\app -> app) toolServerApplication staticApp request respond let responseHeadersMiddleware = insertNewIORefVaultMiddleware responseHeadersVaultKey [] let rlsContextMiddleware = insertNewIORefVaultMiddleware rlsContextVaultKey Nothing diff --git a/ihp/IHP/ControllerPrelude.hs b/ihp/IHP/ControllerPrelude.hs index eb56548d5..09b0bc469 100644 --- a/ihp/IHP/ControllerPrelude.hs +++ b/ihp/IHP/ControllerPrelude.hs @@ -21,7 +21,6 @@ module IHP.ControllerPrelude , module Network.Wai.Parse , module IHP.RouterSupport , module IHP.ValidationSupport - , module IHP.AutoRefresh , module IHP.FlashMessages , module IHP.Controller.Context , module IHP.Modal.Types @@ -70,8 +69,6 @@ import IHP.ViewSupport (View) import qualified IHP.ViewSupport as ViewSupport import IHP.Job.Types -import IHP.AutoRefresh (autoRefresh) - import IHP.LoginSupport.Helper.Controller import IHP.PageHead.ControllerFunctions diff --git a/ihp/IHP/RouterSupport.hs b/ihp/IHP/RouterSupport.hs index 95cd33cfa..63b6615ea 100644 --- a/ihp/IHP/RouterSupport.hs +++ b/ihp/IHP/RouterSupport.hs @@ -870,7 +870,7 @@ startPage action = get (Text.encodeUtf8 (actionPrefixText @action)) action withPrefix prefix routes = string prefix >> choice (map (\r -> r <* endOfInput) routes) {-# INLINABLE withPrefix #-} -frontControllerToWAIApp :: forall app (autoRefreshApp :: Type). (FrontController app, WSApp autoRefreshApp, Typeable autoRefreshApp, InitControllerContext ()) => Middleware -> app -> Application -> Application +frontControllerToWAIApp :: forall app. (FrontController app, InitControllerContext ()) => Middleware -> app -> Application -> Application frontControllerToWAIApp middleware application notFoundAction waiRequest waiRespond = do let -- Use lazy pattern to defer vault lookup until environment is actually needed @@ -885,7 +885,7 @@ frontControllerToWAIApp middleware application notFoundAction waiRequest waiResp handleException :: SomeException -> IO (Either String Application) handleException exception = pure $ Right $ ErrorController.handleRouterException environment exception - routes = let ?application = application in router [let ?application = () in webSocketApp @autoRefreshApp] + routes = let ?application = application in router [] routedAction :: Either String Application <- (do diff --git a/ihp/IHP/Server.hs b/ihp/IHP/Server.hs index c93f66cc4..37be36a95 100644 --- a/ihp/IHP/Server.hs +++ b/ihp/IHP/Server.hs @@ -17,7 +17,6 @@ import qualified IHP.PGListener as PGListener import IHP.FrameworkConfig import IHP.ModelSupport (withModelContext) import IHP.RouterSupport (frontControllerToWAIApp, FrontController) -import IHP.AutoRefresh (AutoRefreshWSApp) import qualified IHP.Job.Runner as Job import qualified IHP.Job.Types as Job import qualified Data.ByteString.Char8 as ByteString @@ -180,7 +179,7 @@ initMiddlewareStack frameworkConfig modelContext maybePgListener = do application :: (FrontController RootApplication) => Application -> Middleware -> Application application staticApp middleware request respond = do - frontControllerToWAIApp @RootApplication @AutoRefreshWSApp middleware RootApplication staticApp request respond + frontControllerToWAIApp @RootApplication middleware RootApplication staticApp request respond {-# INLINABLE application #-} runServer :: FrameworkConfig -> Bool -> Application -> IO () diff --git a/ihp/IHP/ViewPrelude.hs b/ihp/IHP/ViewPrelude.hs index 0ee66b4d6..6fc81fe92 100644 --- a/ihp/IHP/ViewPrelude.hs +++ b/ihp/IHP/ViewPrelude.hs @@ -24,7 +24,6 @@ module IHP.ViewPrelude ( (!), module Data.Data, module Data.Aeson, - module IHP.AutoRefresh.View, module IHP.View.Classes, module IHP.FlashMessages, module IHP.Controller.Context, @@ -53,7 +52,6 @@ import IHP.ModelSupport import IHP.FrameworkConfig import Data.Data import Data.Aeson (ToJSON (..), FromJSON (..), KeyValue (..)) -import IHP.AutoRefresh.View import IHP.View.Types import IHP.View.Classes import IHP.FlashMessages diff --git a/ihp/Test/Test/Main.hs b/ihp/Test/Test/Main.hs index b05dfd435..e90e0b5fd 100644 --- a/ihp/Test/Test/Main.hs +++ b/ihp/Test/Test/Main.hs @@ -22,7 +22,6 @@ import qualified Test.PGListenerSpec import qualified Test.MockingSpec import qualified Test.HasqlEncoderSpec import qualified Test.ControllerSupportSpec -import qualified Test.AutoRefreshSpec import qualified Test.Pagination.ControllerFunctionsSpec main :: IO () @@ -46,5 +45,4 @@ main = hspec do Test.MockingSpec.tests Test.HasqlEncoderSpec.tests Test.ControllerSupportSpec.tests - Test.AutoRefreshSpec.tests Test.Pagination.ControllerFunctionsSpec.tests diff --git a/ihp/ihp.cabal b/ihp/ihp.cabal index e2460641e..ea31c469c 100644 --- a/ihp/ihp.cabal +++ b/ihp/ihp.cabal @@ -229,9 +229,6 @@ library , IHP.ScriptSupport , IHP.AuthSupport.View.Sessions.New , IHP.AuthSupport.Controller.Sessions - , IHP.AutoRefresh - , IHP.AutoRefresh.Types - , IHP.AutoRefresh.View , IHP.WebSocket , IHP.View.Classes , IHP.View.CSSFramework @@ -293,5 +290,4 @@ test-suite tests Test.MockingSpec Test.ControllerSupportSpec Test.HasqlEncoderSpec - Test.AutoRefreshSpec Test.Pagination.ControllerFunctionsSpec From 23f518c5e3f77ba5707364c2c4e6d866a8c3dd45 Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Wed, 18 Feb 2026 15:58:38 +0100 Subject: [PATCH 2/6] Fix ihp-job-dashboard and ApplicationGenerator for AutoRefresh extraction - Add ihp-auto-refresh dependency to ihp-job-dashboard (cabal + nix) - Add explicit import of IHP.AutoRefresh in Dashboard.hs - Remove {autoRefreshMeta} from generated app layouts (now opt-in) Co-Authored-By: Claude Opus 4.6 --- ihp-ide/IHP/IDE/CodeGen/ApplicationGenerator.hs | 1 - ihp-job-dashboard/IHP/Job/Dashboard.hs | 1 + ihp-job-dashboard/default.nix | 6 +++--- ihp-job-dashboard/ihp-job-dashboard.cabal | 1 + 4 files changed, 5 insertions(+), 4 deletions(-) diff --git a/ihp-ide/IHP/IDE/CodeGen/ApplicationGenerator.hs b/ihp-ide/IHP/IDE/CodeGen/ApplicationGenerator.hs index ccfd4e9aa..e9b048b2d 100644 --- a/ihp-ide/IHP/IDE/CodeGen/ApplicationGenerator.hs +++ b/ihp-ide/IHP/IDE/CodeGen/ApplicationGenerator.hs @@ -133,7 +133,6 @@ generateGenericApplication applicationName = <> " \n" <> " \n" <> " \n" - <> " {autoRefreshMeta}\n" <> "|]\n" viewPreludeHs = diff --git a/ihp-job-dashboard/IHP/Job/Dashboard.hs b/ihp-job-dashboard/IHP/Job/Dashboard.hs index ece347711..8e1b71920 100644 --- a/ihp-job-dashboard/IHP/Job/Dashboard.hs +++ b/ihp-job-dashboard/IHP/Job/Dashboard.hs @@ -34,6 +34,7 @@ module IHP.Job.Dashboard ( import IHP.Prelude import IHP.ModelSupport import IHP.ControllerPrelude +import IHP.AutoRefresh (autoRefresh) import Unsafe.Coerce import IHP.Job.Queue () import IHP.Pagination.Types diff --git a/ihp-job-dashboard/default.nix b/ihp-job-dashboard/default.nix index ef0741d1f..96e1673d5 100644 --- a/ihp-job-dashboard/default.nix +++ b/ihp-job-dashboard/default.nix @@ -1,6 +1,6 @@ { mkDerivation, base, blaze-html, blaze-markup, hasql , hasql-dynamic-statements, hasql-implicits, hasql-pool, http-types -, ihp, ihp-hsx, lib, mtl, text, wai +, ihp, ihp-auto-refresh, ihp-hsx, lib, mtl, text, wai , wai-request-params }: mkDerivation { @@ -9,8 +9,8 @@ mkDerivation { src = ./.; libraryHaskellDepends = [ base blaze-html blaze-markup hasql hasql-dynamic-statements - hasql-implicits hasql-pool http-types ihp ihp-hsx mtl - text wai wai-request-params + hasql-implicits hasql-pool http-types ihp ihp-auto-refresh ihp-hsx + mtl text wai wai-request-params ]; homepage = "https://ihp.digitallyinduced.com/"; description = "Dashboard for IHP job runners"; diff --git a/ihp-job-dashboard/ihp-job-dashboard.cabal b/ihp-job-dashboard/ihp-job-dashboard.cabal index 51c987fa3..14b38896a 100644 --- a/ihp-job-dashboard/ihp-job-dashboard.cabal +++ b/ihp-job-dashboard/ihp-job-dashboard.cabal @@ -23,6 +23,7 @@ library , blaze-html , blaze-markup , ihp + , ihp-auto-refresh , ihp-hsx , http-types , wai-request-params From 3ba7231f187e97eaaea9edc3d56d18a405d6849c Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Wed, 18 Feb 2026 16:02:01 +0100 Subject: [PATCH 3/6] Restore {autoRefreshMeta} in generated app layouts ihp-auto-refresh will be a default dependency for new apps. Co-Authored-By: Claude Opus 4.6 --- ihp-ide/IHP/IDE/CodeGen/ApplicationGenerator.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/ihp-ide/IHP/IDE/CodeGen/ApplicationGenerator.hs b/ihp-ide/IHP/IDE/CodeGen/ApplicationGenerator.hs index e9b048b2d..ccfd4e9aa 100644 --- a/ihp-ide/IHP/IDE/CodeGen/ApplicationGenerator.hs +++ b/ihp-ide/IHP/IDE/CodeGen/ApplicationGenerator.hs @@ -133,6 +133,7 @@ generateGenericApplication applicationName = <> " \n" <> " \n" <> " \n" + <> " {autoRefreshMeta}\n" <> "|]\n" viewPreludeHs = From a92a7c3c67dbd272463fe041e1d7db41c74a9ac2 Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Wed, 18 Feb 2026 17:04:41 +0100 Subject: [PATCH 4/6] Add missing typerep-map dependency to ihp-auto-refresh AutoRefresh.hs imports Data.TMap which requires typerep-map. Co-Authored-By: Claude Opus 4.6 --- ihp-auto-refresh/default.nix | 8 ++++---- ihp-auto-refresh/ihp-auto-refresh.cabal | 1 + 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/ihp-auto-refresh/default.nix b/ihp-auto-refresh/default.nix index bc2aa3a51..19522aa3d 100644 --- a/ihp-auto-refresh/default.nix +++ b/ihp-auto-refresh/default.nix @@ -1,8 +1,8 @@ { mkDerivation, async, base, basic-prelude, binary, blaze-html , bytestring, containers, hasql, hasql-dynamic-statements , hasql-pool, ihp, ihp-context, ihp-hsx, ihp-log, ihp-pglistener -, lib, string-conversions, text, time, uuid, vault, wai -, wai-request-params, websockets +, lib, string-conversions, text, time, typerep-map, uuid, vault +, wai, wai-request-params, websockets }: mkDerivation { pname = "ihp-auto-refresh"; @@ -11,8 +11,8 @@ mkDerivation { libraryHaskellDepends = [ async base basic-prelude binary blaze-html bytestring containers hasql hasql-dynamic-statements hasql-pool ihp ihp-context ihp-hsx - ihp-log ihp-pglistener string-conversions text time uuid vault wai - wai-request-params websockets + ihp-log ihp-pglistener string-conversions text time typerep-map + uuid vault wai wai-request-params websockets ]; description = "AutoRefresh for IHP"; license = lib.licenses.mit; diff --git a/ihp-auto-refresh/ihp-auto-refresh.cabal b/ihp-auto-refresh/ihp-auto-refresh.cabal index d3bc925c8..a0477246a 100644 --- a/ihp-auto-refresh/ihp-auto-refresh.cabal +++ b/ihp-auto-refresh/ihp-auto-refresh.cabal @@ -58,6 +58,7 @@ library , blaze-html , text , bytestring + , typerep-map , wai-request-params exposed-modules: IHP.AutoRefresh From 954df0f8e36fe0e7fc909b35d767767e58816f07 Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Wed, 18 Feb 2026 17:14:41 +0100 Subject: [PATCH 5/6] Fix ihp-auto-refresh test-suite: use separate hs-source-dirs The test-suite had hs-source-dirs: . which caused cabal to treat library source files as "home modules" of the test suite, leading to hidden package errors during nix build. Changed to hs-source-dirs: Test so tests get library modules from the ihp-auto-refresh dependency. Co-Authored-By: Claude Opus 4.6 --- ihp-auto-refresh/Test/AutoRefreshSpec.hs | 4 ++-- ihp-auto-refresh/Test/Main.hs | 4 ++-- ihp-auto-refresh/ihp-auto-refresh.cabal | 6 +++--- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/ihp-auto-refresh/Test/AutoRefreshSpec.hs b/ihp-auto-refresh/Test/AutoRefreshSpec.hs index cb7010d75..80fb963e3 100644 --- a/ihp-auto-refresh/Test/AutoRefreshSpec.hs +++ b/ihp-auto-refresh/Test/AutoRefreshSpec.hs @@ -1,11 +1,11 @@ {-| -Module: Test.AutoRefreshSpec +Module: AutoRefreshSpec Tests that AutoRefresh preserves query parameters when re-rendering with a bare WebSocket request (no query params). -} {-# LANGUAGE AllowAmbiguousTypes #-} -module Test.AutoRefreshSpec where +module AutoRefreshSpec where import Test.Hspec import IHP.Prelude import IHP.Environment diff --git a/ihp-auto-refresh/Test/Main.hs b/ihp-auto-refresh/Test/Main.hs index 7e30a7fa5..9278dc711 100644 --- a/ihp-auto-refresh/Test/Main.hs +++ b/ihp-auto-refresh/Test/Main.hs @@ -3,8 +3,8 @@ module Main where import Test.Hspec import IHP.Prelude -import qualified Test.AutoRefreshSpec +import qualified AutoRefreshSpec main :: IO () main = hspec do - Test.AutoRefreshSpec.tests + AutoRefreshSpec.tests diff --git a/ihp-auto-refresh/ihp-auto-refresh.cabal b/ihp-auto-refresh/ihp-auto-refresh.cabal index a0477246a..11332cde5 100644 --- a/ihp-auto-refresh/ihp-auto-refresh.cabal +++ b/ihp-auto-refresh/ihp-auto-refresh.cabal @@ -68,8 +68,8 @@ library test-suite tests import: shared-properties type: exitcode-stdio-1.0 - main-is: Test/Main.hs - hs-source-dirs: . + main-is: Main.hs + hs-source-dirs: Test ghc-options: -threaded build-depends: base >= 4.17.0 && < 4.22 @@ -86,4 +86,4 @@ test-suite tests , bytestring , wai-request-params other-modules: - Test.AutoRefreshSpec + AutoRefreshSpec From 97cb8c95a18205b0dc63bfa719ca2de527280af1 Mon Sep 17 00:00:00 2001 From: Marc Scholten Date: Thu, 19 Feb 2026 10:14:50 +0100 Subject: [PATCH 6/6] Fix missing autoRefresh import in test suite Since IHP.ControllerPrelude no longer re-exports autoRefresh, the test needs to import it explicitly from IHP.AutoRefresh. Co-Authored-By: Claude Opus 4.6 --- ihp-auto-refresh/Test/AutoRefreshSpec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ihp-auto-refresh/Test/AutoRefreshSpec.hs b/ihp-auto-refresh/Test/AutoRefreshSpec.hs index 80fb963e3..492dae1fc 100644 --- a/ihp-auto-refresh/Test/AutoRefreshSpec.hs +++ b/ihp-auto-refresh/Test/AutoRefreshSpec.hs @@ -14,7 +14,7 @@ import IHP.ControllerPrelude hiding (get, request) import Network.Wai import Network.Wai.Internal (ResponseReceived(..)) import Network.HTTP.Types -import IHP.AutoRefresh (globalAutoRefreshServerVar) +import IHP.AutoRefresh (autoRefresh, globalAutoRefreshServerVar) import IHP.AutoRefresh.Types import qualified Control.Concurrent.MVar as MVar import IHP.Controller.Response (ResponseException(..))