{-|
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 hiding (request)
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 Network.Wai.Middleware.EarlyReturn (earlyReturnMiddleware)
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 IHP.RequestVault (pgListenerVaultKey)
import IHP.FrameworkConfig.Types (FrameworkConfig(..))
import IHP.Environment (Environment(..))

{-# NOINLINE globalAutoRefreshServerVar #-}
globalAutoRefreshServerVar :: MVar.MVar (Maybe (IORef AutoRefreshServer))
globalAutoRefreshServerVar :: MVar (Maybe (IORef AutoRefreshServer))
globalAutoRefreshServerVar = IO (MVar (Maybe (IORef AutoRefreshServer)))
-> MVar (Maybe (IORef AutoRefreshServer))
forall a. IO a -> a
unsafePerformIO (Maybe (IORef AutoRefreshServer)
-> IO (MVar (Maybe (IORef AutoRefreshServer)))
forall a. a -> IO (MVar a)
MVar.newMVar Maybe (IORef AutoRefreshServer)
forall a. Maybe a
Nothing)

getOrCreateAutoRefreshServer :: (?request :: Request) => IO (IORef AutoRefreshServer)
getOrCreateAutoRefreshServer :: (?request::Request) => IO (IORef AutoRefreshServer)
getOrCreateAutoRefreshServer =
    MVar (Maybe (IORef AutoRefreshServer))
-> (Maybe (IORef AutoRefreshServer)
    -> IO (Maybe (IORef AutoRefreshServer), IORef AutoRefreshServer))
-> IO (IORef AutoRefreshServer)
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
MVar.modifyMVar MVar (Maybe (IORef AutoRefreshServer))
globalAutoRefreshServerVar ((Maybe (IORef AutoRefreshServer)
  -> IO (Maybe (IORef AutoRefreshServer), IORef AutoRefreshServer))
 -> IO (IORef AutoRefreshServer))
-> (Maybe (IORef AutoRefreshServer)
    -> IO (Maybe (IORef AutoRefreshServer), IORef AutoRefreshServer))
-> IO (IORef AutoRefreshServer)
forall a b. (a -> b) -> a -> b
$ \case
        Just IORef AutoRefreshServer
server -> (Maybe (IORef AutoRefreshServer), IORef AutoRefreshServer)
-> IO (Maybe (IORef AutoRefreshServer), IORef AutoRefreshServer)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IORef AutoRefreshServer -> Maybe (IORef AutoRefreshServer)
forall a. a -> Maybe a
Just IORef AutoRefreshServer
server, IORef AutoRefreshServer
server)
        Maybe (IORef AutoRefreshServer)
Nothing -> do
            let pgListener :: PGListener
pgListener = case Key PGListener -> Vault -> Maybe PGListener
forall a. Key a -> Vault -> Maybe a
Vault.lookup Key PGListener
pgListenerVaultKey ?request::Request
Request
?request.vault of
                    Just PGListener
pl -> PGListener
pl
                    Maybe PGListener
Nothing -> Text -> PGListener
forall a. Text -> a
error Text
"getOrCreateAutoRefreshServer: PGListener not found in request vault"
            server <- AutoRefreshServer -> IO (IORef AutoRefreshServer)
forall a. a -> IO (IORef a)
newIORef (PGListener -> AutoRefreshServer
newAutoRefreshServer PGListener
pgListener)
            pure (Just server, server)

autoRefresh :: (
    ?theAction :: action
    , Controller action
    , ?modelContext :: ModelContext
    , ?context :: ControllerContext
    , ?request :: Request
    , ?respond :: Respond
    ) => ((?modelContext :: ModelContext, ?respond :: Respond, ?request :: Request) => IO ResponseReceived) -> IO ResponseReceived
autoRefresh :: forall action.
(?theAction::action, Controller action,
 ?modelContext::ModelContext, ?context::ControllerContext,
 ?request::Request, ?respond::Respond) =>
((?modelContext::ModelContext, ?respond::Respond,
  ?request::Request) =>
 IO ResponseReceived)
-> IO ResponseReceived
autoRefresh (?modelContext::ModelContext, ?respond::Respond,
 ?request::Request) =>
IO ResponseReceived
runAction = do
    -- When PGListener is not available, degrade gracefully to a
    -- plain action without auto-refresh.
    case Key PGListener -> Vault -> Maybe PGListener
forall a. Key a -> Vault -> Maybe a
Vault.lookup Key PGListener
pgListenerVaultKey ?request::Request
Request
?request.vault of
        Maybe PGListener
Nothing -> IO ResponseReceived
(?modelContext::ModelContext, ?respond::Respond,
 ?request::Request) =>
IO ResponseReceived
runAction
        Just PGListener
_ -> do
            let autoRefreshState :: Maybe AutoRefreshState
autoRefreshState = Key AutoRefreshState -> Vault -> Maybe AutoRefreshState
forall a. Key a -> Vault -> Maybe a
Vault.lookup Key AutoRefreshState
autoRefreshStateVaultKey ?request::Request
Request
?request.vault
            autoRefreshServer <- IO (IORef AutoRefreshServer)
(?request::Request) => IO (IORef 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
                Maybe AutoRefreshState
_ -> do
                    availableSessions <- (?request::Request) => IORef AutoRefreshServer -> IO [UUID]
IORef AutoRefreshServer -> IO [UUID]
getAvailableSessions IORef AutoRefreshServer
autoRefreshServer

                    id <- UUID.nextRandom

                    -- Update the vault with AutoRefreshEnabled so that autoRefreshMeta can read it
                    let newRequest = ?request::Request
Request
?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

                    let originalRequest = ?request::Request
Request
?request
                    let renderView = \Request
waiRequest Respond
waiRespond -> do
                            Middleware
earlyReturnMiddleware (\Request
_ Respond
respond -> do
                                controllerContext <- ControllerContext -> IO ControllerContext
unfreeze ControllerContext
frozenControllerContext
                                let ?context = controllerContext
                                let ?request = originalRequest
                                let ?respond = respond
                                action ?theAction
                                ) Request
waiRequest Respond
waiRespond

                    -- 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
                        (result, capturedResponse) <- captureResponseBody ?respond \Respond
respond -> do
                            let ?respond = ?respond::Respond
Respond
respond
                            IO ResponseReceived
(?modelContext::ModelContext, ?respond::Respond,
 ?request::Request) =>
IO ResponseReceived
runAction

                        -- After the action completes, set up the auto refresh session
                        tables <- readIORef ?touchedTables
                        lastPing <- getCurrentTime
                        case capturedResponse of
                            Just LByteString
lastResponse -> do
                                event <- IO (MVar ())
forall a. IO (MVar a)
MVar.newEmptyMVar
                                let session = AutoRefreshSession { UUID
id :: UUID
id :: UUID
id, Request -> Respond -> IO ResponseReceived
renderView :: Request -> Respond -> IO ResponseReceived
renderView :: Request -> Respond -> IO ResponseReceived
renderView, MVar ()
event :: MVar ()
event :: MVar ()
event, Set Text
tables :: Set Text
tables :: Set Text
tables, LByteString
lastResponse :: LByteString
lastResponse :: LByteString
lastResponse, UTCTime
lastPing :: UTCTime
lastPing :: UTCTime
lastPing }
                                modifyIORef' autoRefreshServer (\AutoRefreshServer
s -> AutoRefreshServer
s { sessions = session:s.sessions } )
                                async (gcSessions autoRefreshServer)
                                registerNotificationTrigger ?touchedTables autoRefreshServer
                            Maybe LByteString
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () -- Response wasn't a builder type, can't do auto refresh

                        pure result

data AutoRefreshWSApp = AwaitingSessionID | AutoRefreshActive { AutoRefreshWSApp -> UUID
sessionId :: UUID }
instance WSApp AutoRefreshWSApp where
    initialState :: AutoRefreshWSApp
initialState = AutoRefreshWSApp
AwaitingSessionID

    run :: (?state::IORef AutoRefreshWSApp, ?context::ControllerContext,
 ?modelContext::ModelContext, ?connection::Connection,
 ?request::Request) =>
IO ()
run = do
        sessionId <- forall a. (?connection::Connection, WebSocketsData a) => IO a
receiveData @UUID
        setState AutoRefreshActive { sessionId }

        autoRefreshServer <- getOrCreateAutoRefreshServer
        availableSessions <- getAvailableSessions autoRefreshServer

        when (sessionId `elem` availableSessions) do
            AutoRefreshSession { renderView, event } <- getSessionById autoRefreshServer sessionId

            let handleOtherException :: SomeException -> IO ()
                handleOtherException SomeException
ex = Text -> IO ()
forall context string.
(?context::context, LoggingProvider context, ToLogStr string) =>
string -> IO ()
Log.error (Text
"AutoRefresh: Failed to re-render view: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeException -> Text
forall a. Show a => a -> Text
tshow SomeException
ex)

            async $ forever do
                MVar.takeMVar event
                let currentRequest = ?request::Request
Request
?request
                (do
                    (_, capturedResponse) <- captureResponseBody (\Response
_ -> ResponseReceived -> IO ResponseReceived
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> ResponseReceived
forall a. Text -> a
error Text
"AutoRefresh: ResponseReceived placeholder")) \Respond
respond ->
                        Request -> Respond -> IO ResponseReceived
renderView Request
currentRequest Respond
respond
                    case capturedResponse of
                        Just LByteString
html -> do
                            responseChanged <- IORef AutoRefreshServer -> UUID -> LByteString -> IO Bool
sessionResponseHasChanged IORef AutoRefreshServer
autoRefreshServer UUID
sessionId LByteString
html
                            when responseChanged do
                                sendTextData html
                                updateSession autoRefreshServer sessionId (\AutoRefreshSession
session -> AutoRefreshSession
session { lastResponse = html })
                        Maybe LByteString
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                    ) `catch` handleOtherException
                pure ()

            pure ()

        -- Keep the connection open until it's killed and the onClose is called
        forever receiveDataMessage

    onPing :: (?state::IORef AutoRefreshWSApp, ?context::ControllerContext,
 ?modelContext::ModelContext, ?request::Request) =>
IO ()
onPing = do
        now <- IO UTCTime
getCurrentTime
        AutoRefreshActive { sessionId } <- getState
        autoRefreshServer <- getOrCreateAutoRefreshServer
        updateSession autoRefreshServer sessionId (\AutoRefreshSession
session -> AutoRefreshSession
session { lastPing = now })

    onClose :: (?state::IORef AutoRefreshWSApp, ?context::ControllerContext,
 ?modelContext::ModelContext, ?connection::Connection,
 ?request::Request) =>
IO ()
onClose = do
        IO AutoRefreshWSApp
forall state. (?state::IORef state) => IO state
getState IO AutoRefreshWSApp -> (AutoRefreshWSApp -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            AutoRefreshActive { UUID
sessionId :: AutoRefreshWSApp -> UUID
sessionId :: UUID
sessionId } -> do
                autoRefreshServer <- IO (IORef AutoRefreshServer)
(?request::Request) => IO (IORef AutoRefreshServer)
getOrCreateAutoRefreshServer
                modifyIORef' autoRefreshServer (\AutoRefreshServer
server -> AutoRefreshServer
server { sessions = filter (\AutoRefreshSession { UUID
id :: AutoRefreshSession -> UUID
id :: UUID
id } -> UUID
id UUID -> UUID -> Bool
forall a. Eq a => a -> a -> Bool
/= UUID
sessionId) server.sessions })
            AutoRefreshWSApp
AwaitingSessionID -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


-- | Runs an action while capturing the response body.
-- Returns the action's result and the captured body (if it was a ResponseBuilder).
-- Only captures ResponseBuilder responses (used by HSX/Blaze rendering).
captureResponseBody :: Respond -> (Respond -> IO a) -> IO (a, Maybe LByteString)
captureResponseBody :: forall a. Respond -> (Respond -> IO a) -> IO (a, Maybe LByteString)
captureResponseBody Respond
originalRespond Respond -> IO a
action = do
    bodyRef <- Maybe LByteString -> IO (IORef (Maybe LByteString))
forall a. a -> IO (IORef a)
newIORef Maybe LByteString
forall a. Maybe a
Nothing
    let capturingRespond Response
response = do
            case Response
response of
                Wai.ResponseBuilder Status
_status ResponseHeaders
_headers Builder
builder -> do
                    let body :: LByteString
body = Builder -> LByteString
ByteString.toLazyByteString Builder
builder
                    evaluatedBody <- LByteString -> IO LByteString
forall a. a -> IO a
Exception.evaluate LByteString
body
                    writeIORef bodyRef (Just evaluatedBody)
                Response
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Respond
originalRespond Response
response
    result <- action capturingRespond
    captured <- readIORef bodyRef
    pure (result, captured)

registerNotificationTrigger :: (?modelContext :: ModelContext, ?context :: ControllerContext) => IORef (Set Text) -> IORef AutoRefreshServer -> IO ()
registerNotificationTrigger :: (?modelContext::ModelContext, ?context::ControllerContext) =>
IORef (Set Text) -> IORef AutoRefreshServer -> IO ()
registerNotificationTrigger IORef (Set Text)
touchedTablesVar IORef AutoRefreshServer
autoRefreshServer = do
    touchedTables <- Set Text -> [Text]
forall a. Set a -> [a]
Set.toList (Set Text -> [Text]) -> IO (Set Text) -> IO [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Set Text) -> IO (Set Text)
forall a. IORef a -> IO a
readIORef IORef (Set Text)
touchedTablesVar
    subscribedTables <- (.subscribedTables) <$> (autoRefreshServer |> readIORef)

    let subscriptionRequired = [Text]
touchedTables [Text] -> ([Text] -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
|> (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Text
table -> Set Text
subscribedTables Set Text -> (Set Text -> Bool) -> Bool
forall a b. a -> (a -> b) -> b
|> Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember Text
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::ControllerContext
ControllerContext
?context.frameworkConfig.environment Environment -> Environment -> Bool
forall a. Eq a => a -> a -> Bool
== Environment
Development

    modifyIORef' autoRefreshServer (\AutoRefreshServer
server -> AutoRefreshServer
server { subscribedTables = server.subscribedTables <> Set.fromList subscriptionRequired })

    pgListener <- (.pgListener) <$> readIORef autoRefreshServer
    subscriptions <- subscriptionRequired |> mapM (\Text
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
        ((?modelContext::ModelContext) => IO ()) -> IO ()
forall a.
(?modelContext::ModelContext) =>
((?modelContext::ModelContext) => IO a) -> IO a
withRowLevelSecurityDisabled do
            let pool :: Pool
pool = ?modelContext::ModelContext
ModelContext
?modelContext.hasqlPool
            (?modelContext::ModelContext) => Pool -> Session () -> IO ()
Pool -> Session () -> IO ()
runSessionHasql Pool
pool (Text -> Session ()
HasqlSession.script (Text -> Text
notificationTriggerSQL Text
table))

        PGListener
pgListener PGListener -> (PGListener -> IO Subscription) -> IO Subscription
forall a b. a -> (a -> b) -> b
|> ByteString -> Callback -> PGListener -> IO Subscription
PGListener.subscribe (Text -> ByteString
channelName Text
table) \Notification
notification -> do
                sessions <- (.sessions) (AutoRefreshServer -> [AutoRefreshSession])
-> IO AutoRefreshServer -> IO [AutoRefreshSession]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef AutoRefreshServer -> IO AutoRefreshServer
forall a. IORef a -> IO a
readIORef IORef AutoRefreshServer
autoRefreshServer
                sessions
                    |> filter (\AutoRefreshSession
session -> Text
table Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` AutoRefreshSession
session.tables)
                    |> map (\AutoRefreshSession
session -> AutoRefreshSession
session.event)
                    |> mapM (\MVar ()
event -> MVar () -> () -> IO Bool
forall a. MVar a -> a -> IO Bool
MVar.tryPutMVar MVar ()
event ())
                pure ())

    -- Re-run trigger SQL for already-subscribed tables in dev mode
    when isDevelopment do
        let alreadySubscribed = [Text]
touchedTables [Text] -> ([Text] -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
|> (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Text
table -> Set Text
subscribedTables Set Text -> (Set Text -> Bool) -> Bool
forall a b. a -> (a -> b) -> b
|> Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Text
table)
        forM_ alreadySubscribed \Text
table -> do
            ((?modelContext::ModelContext) => IO ()) -> IO ()
forall a.
(?modelContext::ModelContext) =>
((?modelContext::ModelContext) => IO a) -> IO a
withRowLevelSecurityDisabled do
                let pool :: Pool
pool = ?modelContext::ModelContext
ModelContext
?modelContext.hasqlPool
                (?modelContext::ModelContext) => Pool -> Session () -> IO ()
Pool -> Session () -> IO ()
runSessionHasql Pool
pool (Text -> Session ()
HasqlSession.script (Text -> Text
notificationTriggerSQL Text
table))

    modifyIORef' autoRefreshServer (\AutoRefreshServer
s -> AutoRefreshServer
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 :: (?request::Request) => IORef AutoRefreshServer -> IO [UUID]
getAvailableSessions IORef AutoRefreshServer
autoRefreshServer = do
    allSessions <- (.sessions) (AutoRefreshServer -> [AutoRefreshSession])
-> IO AutoRefreshServer -> IO [AutoRefreshSession]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef AutoRefreshServer -> IO AutoRefreshServer
forall a. IORef a -> IO a
readIORef IORef AutoRefreshServer
autoRefreshServer
    text <- fromMaybe "" <$> getSession "autoRefreshSessions"
    let uuidCharCount = Text -> Int
Text.length (UUID -> Text
UUID.toText UUID
UUID.nil)
    let allSessionIds = (AutoRefreshSession -> UUID) -> [AutoRefreshSession] -> [UUID]
forall a b. (a -> b) -> [a] -> [b]
map (.id) [AutoRefreshSession]
allSessions
    text
        |> Text.chunksOf uuidCharCount
        |> mapMaybe UUID.fromText
        |> filter (\UUID
id -> UUID
id UUID -> [UUID] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [UUID]
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 :: IORef AutoRefreshServer -> UUID -> IO AutoRefreshSession
getSessionById IORef AutoRefreshServer
autoRefreshServer UUID
sessionId = do
    autoRefreshServer <- IORef AutoRefreshServer -> IO AutoRefreshServer
forall a. IORef a -> IO a
readIORef IORef AutoRefreshServer
autoRefreshServer
    autoRefreshServer.sessions
        |> find (\AutoRefreshSession { UUID
id :: AutoRefreshSession -> UUID
id :: UUID
id } -> UUID
id UUID -> UUID -> Bool
forall a. Eq a => a -> a -> Bool
== UUID
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 :: IORef AutoRefreshServer
-> UUID -> (AutoRefreshSession -> AutoRefreshSession) -> IO ()
updateSession IORef AutoRefreshServer
server UUID
sessionId AutoRefreshSession -> AutoRefreshSession
updateFunction = do
    let updateSession' :: AutoRefreshSession -> AutoRefreshSession
updateSession' AutoRefreshSession
session = if AutoRefreshSession
session.id UUID -> UUID -> Bool
forall a. Eq a => a -> a -> Bool
== UUID
sessionId then AutoRefreshSession -> AutoRefreshSession
updateFunction AutoRefreshSession
session else AutoRefreshSession
session
    IORef AutoRefreshServer
-> (AutoRefreshServer -> AutoRefreshServer) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef AutoRefreshServer
server (\AutoRefreshServer
server -> AutoRefreshServer
server { sessions = map updateSession' server.sessions })
    () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Returns 'True' when the rendered html differs from the session's latest
-- known response.
--
-- This must read the current session state instead of comparing against a
-- websocket-local snapshot, otherwise switching back to an earlier DOM state
-- can be incorrectly suppressed as "unchanged".
sessionResponseHasChanged :: IORef AutoRefreshServer -> UUID -> LByteString -> IO Bool
sessionResponseHasChanged :: IORef AutoRefreshServer -> UUID -> LByteString -> IO Bool
sessionResponseHasChanged IORef AutoRefreshServer
autoRefreshServer UUID
sessionId LByteString
html = do
    currentLastResponse <- (.lastResponse) (AutoRefreshSession -> LByteString)
-> IO AutoRefreshSession -> IO LByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef AutoRefreshServer -> UUID -> IO AutoRefreshSession
getSessionById IORef AutoRefreshServer
autoRefreshServer UUID
sessionId
    pure (html /= currentLastResponse)

-- | 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 :: IORef AutoRefreshServer -> IO ()
gcSessions IORef AutoRefreshServer
autoRefreshServer = do
    now <- IO UTCTime
getCurrentTime
    modifyIORef' autoRefreshServer (\AutoRefreshServer
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 :: UTCTime -> AutoRefreshSession -> Bool
isSessionExpired UTCTime
now AutoRefreshSession { UTCTime
lastPing :: AutoRefreshSession -> UTCTime
lastPing :: UTCTime
lastPing } = (UTCTime
now UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
lastPing) NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> (Pico -> NominalDiffTime
secondsToNominalDiffTime Pico
60)

-- | Returns the event name of the event that the pg notify trigger dispatches
channelName :: Text -> ByteString
channelName :: Text -> ByteString
channelName Text
tableName = ByteString
"ar_did_change_" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs Text
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 :: Text -> Text
notificationTriggerSQL Text
tableName =
        Text
"DO $$\n"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"BEGIN\n"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"    CREATE OR REPLACE FUNCTION " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
functionName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"() RETURNS TRIGGER AS $BODY$"
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"BEGIN\n"
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"    PERFORM pg_notify('" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> ByteString
channelName Text
tableName) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"', '');\n"
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"    RETURN new;\n"
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"END;\n"
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"$BODY$ language plpgsql;\n"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"    DROP TRIGGER IF EXISTS " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
insertTriggerName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ON " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tableName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
";\n"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"    CREATE TRIGGER " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
insertTriggerName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" AFTER INSERT ON \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tableName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" FOR EACH STATEMENT EXECUTE PROCEDURE " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
functionName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"();\n"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"    DROP TRIGGER IF EXISTS " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
updateTriggerName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ON " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tableName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
";\n"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"    CREATE TRIGGER " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
updateTriggerName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" AFTER UPDATE ON \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tableName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" FOR EACH STATEMENT EXECUTE PROCEDURE " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
functionName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"();\n"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"    DROP TRIGGER IF EXISTS " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
deleteTriggerName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ON " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tableName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
";\n"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"    CREATE TRIGGER " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
deleteTriggerName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" AFTER DELETE ON \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tableName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" FOR EACH STATEMENT EXECUTE PROCEDURE " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
functionName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"();\n"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"EXCEPTION\n"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"    WHEN SQLSTATE 'XX000' THEN null; -- 'tuple concurrently updated': another connection installed it first\n"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"END; $$"
    where
        functionName :: Text
functionName = Text
"ar_notify_did_change_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tableName
        insertTriggerName :: Text
insertTriggerName = Text
"ar_did_insert_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tableName
        updateTriggerName :: Text
updateTriggerName = Text
"ar_did_update_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tableName
        deleteTriggerName :: Text
deleteTriggerName = Text
"ar_did_delete_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tableName

autoRefreshStateVaultKey :: Vault.Key AutoRefreshState
autoRefreshStateVaultKey :: Key AutoRefreshState
autoRefreshStateVaultKey = IO (Key AutoRefreshState) -> Key AutoRefreshState
forall a. IO a -> a
unsafePerformIO IO (Key AutoRefreshState)
forall a. IO (Key a)
Vault.newKey
{-# NOINLINE autoRefreshStateVaultKey #-}