Extract ihp-auto-refresh into its own package

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";

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 }

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|<meta property="ihp-auto-refresh-id" content={tshow sessionId}/>|]
+        _ -> mempty

ihp-auto-refresh/Test/AutoRefreshSpec.hs

@@ -0,0 +1,146 @@
+{-|
+Module: AutoRefreshSpec
+Tests that AutoRefresh preserves query parameters when re-rendering
+with a bare WebSocket request (no query params).
+-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+
+module 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 (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)

ihp-auto-refresh/Test/Main.hs

@@ -0,0 +1,10 @@
+module Main where
+
+import Test.Hspec
+import IHP.Prelude
+
+import qualified AutoRefreshSpec
+
+main :: IO ()
+main = hspec do
+    AutoRefreshSpec.tests

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, typerep-map, 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 typerep-map
+    uuid vault wai wai-request-params websockets
+  ];
+  description = "AutoRefresh for IHP";
+  license = lib.licenses.mit;
+}

ihp-auto-refresh/ihp-auto-refresh.cabal

@@ -0,0 +1,89 @@
+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
+        , typerep-map
+        , 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: Main.hs
+    hs-source-dirs: Test
+    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:
+        AutoRefreshSpec

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

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

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";

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

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