{-|
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 :: 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
    ) => ((?modelContext :: ModelContext) => IO ()) -> IO ()
autoRefresh :: forall action.
(?theAction::action, Controller action,
 ?modelContext::ModelContext, ?context::ControllerContext,
 ?request::Request) =>
((?modelContext::ModelContext) => IO ()) -> IO ()
autoRefresh (?modelContext::ModelContext) => IO ()
runAction = 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
            -- 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::Request
Request
?request
            let renderView = \Request
_waiRequest Respond
waiRespond -> do
                    controllerContext <- ControllerContext -> IO ControllerContext
unfreeze ControllerContext
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
exception@(ResponseException Response
response) = case Response
response of
                        Wai.ResponseBuilder Status
status ResponseHeaders
headers Builder
builder -> do
                            tables <- IORef (Set Text) -> IO (Set Text)
forall a. IORef a -> IO a
readIORef ?touchedTables::IORef (Set Text)
IORef (Set Text)
?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 { UUID
id :: UUID
id :: UUID
id, Request -> Respond -> IO ()
renderView :: Request -> Respond -> IO ()
renderView :: Request -> Respond -> IO ()
renderView, MVar ()
event :: MVar ()
event :: MVar ()
event, Set Text
tables :: Set Text
tables :: Set Text
tables, LazyByteString
lastResponse :: LazyByteString
lastResponse :: LazyByteString
lastResponse, UTCTime
lastPing :: UTCTime
lastPing :: UTCTime
lastPing }
                            modifyIORef' autoRefreshServer (\AutoRefreshServer
s -> AutoRefreshServer
s { sessions = session:s.sessions } )
                            async (gcSessions autoRefreshServer)

                            registerNotificationTrigger ?touchedTables autoRefreshServer

                            throw exception
                        Response
_   -> Text -> IO ()
forall a. Text -> a
error Text
"Unimplemented WAI response type."

                runAction `Exception.catch` handleResponse

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, lastResponse } <- getSessionById autoRefreshServer sessionId

            let handleResponseException (ResponseException Response
response) = case Response
response of
                    Wai.ResponseBuilder Status
status ResponseHeaders
headers Builder
builder -> do
                        let html :: LazyByteString
html = Builder -> LazyByteString
ByteString.toLazyByteString Builder
builder

                        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LazyByteString
html LazyByteString -> LazyByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= LazyByteString
lastResponse) do
                            LazyByteString -> IO ()
forall text.
(?connection::Connection, WebSocketsData text) =>
text -> IO ()
sendTextData LazyByteString
html
                            IORef AutoRefreshServer
-> UUID -> (AutoRefreshSession -> AutoRefreshSession) -> IO ()
updateSession IORef AutoRefreshServer
autoRefreshServer UUID
sessionId (\AutoRefreshSession
session -> AutoRefreshSession
session { lastResponse = html })
                    Response
_   -> Text -> IO ()
forall a. Text -> a
error Text
"Unimplemented WAI response type."

            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
                -- Create a dummy respond function that does nothing, since actual response
                -- is handled by the handleResponseException handler
                let dummyRespond p
_ = Text -> a
forall a. Text -> a
error Text
"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 :: (?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 ()


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 ()

-- | 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 #-}