{-|
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 IHP.ApplicationContext
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 qualified IHP.PGListener as PGListener
import qualified Database.PostgreSQL.Simple.Types as PG
import Data.String.Interpolate.IsString

initAutoRefresh :: (?context :: ControllerContext, ?applicationContext :: ApplicationContext) => IO ()
initAutoRefresh :: (?context::ControllerContext,
 ?applicationContext::ApplicationContext) =>
IO ()
initAutoRefresh = do
    forall value.
(?context::ControllerContext, Typeable value) =>
value -> IO ()
putContext AutoRefreshState
AutoRefreshDisabled
    forall value.
(?context::ControllerContext, Typeable value) =>
value -> IO ()
putContext (?applicationContext::ApplicationContext
?applicationContext forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get forall a. IsLabel "autoRefreshServer" a => a
#autoRefreshServer)

autoRefresh :: (
    ?theAction :: action
    , Controller action
    , ?modelContext :: ModelContext
    , ?context :: ControllerContext
    ) => ((?modelContext :: ModelContext) => IO ()) -> IO ()
autoRefresh :: forall action.
(?theAction::action, Controller action,
 ?modelContext::ModelContext, ?context::ControllerContext) =>
((?modelContext::ModelContext) => IO ()) -> IO ()
autoRefresh (?modelContext::ModelContext) => IO ()
runAction = do
    AutoRefreshState
autoRefreshState <- forall value.
(?context::ControllerContext, Typeable value) =>
IO value
fromContext @AutoRefreshState
    IORef AutoRefreshServer
autoRefreshServer <- forall value.
(?context::ControllerContext, Typeable value) =>
IO value
fromContext @(IORef AutoRefreshServer)

    case AutoRefreshState
autoRefreshState of
        AutoRefreshState
AutoRefreshDisabled -> do
            [UUID]
availableSessions <- (?context::ControllerContext) =>
IORef AutoRefreshServer -> IO [UUID]
getAvailableSessions IORef AutoRefreshServer
autoRefreshServer

            UUID
id <- IO UUID
UUID.nextRandom

            -- 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
            ControllerContext
frozenControllerContext <- ControllerContext -> IO ControllerContext
freeze ?context::ControllerContext
?context

            let renderView :: RequestContext -> IO ()
renderView = \RequestContext
requestContext -> do
                    ControllerContext
controllerContext <- ControllerContext -> IO ControllerContext
unfreeze ControllerContext
frozenControllerContext
                    let ?context = ControllerContext
controllerContext { RequestContext
$sel:requestContext:ControllerContext :: RequestContext
requestContext :: RequestContext
requestContext }
                    forall controller.
(Controller controller, ?context::ControllerContext,
 ?modelContext::ModelContext, ?theAction::controller) =>
controller -> IO ()
action ?theAction::action
?theAction

            forall value.
(?context::ControllerContext, Typeable value) =>
value -> IO ()
putContext (UUID -> AutoRefreshState
AutoRefreshEnabled UUID
id)

            -- 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
            forall value.
(?context::ControllerContext, Serialize value) =>
ByteString -> value -> IO ()
setSession ByteString
"autoRefreshSessions" (forall a b. (a -> b) -> [a] -> [b]
map UUID -> Text
UUID.toText (UUID
idforall a. a -> [a] -> [a]
:[UUID]
availableSessions) forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> Text -> [Text] -> Text
Text.intercalate Text
"")

            (?modelContext::ModelContext) =>
((?modelContext::ModelContext,
  ?touchedTables::IORef (Set ByteString)) =>
 IO ())
-> IO ()
withTableReadTracker do
                let handleResponse :: ResponseException -> IO ()
handleResponse exception :: ResponseException
exception@(ResponseException Response
response) = case Response
response of
                        Wai.ResponseBuilder Status
status ResponseHeaders
headers Builder
builder -> do
                            Set ByteString
tables <- forall a. IORef a -> IO a
readIORef ?touchedTables::IORef (Set ByteString)
?touchedTables
                            UTCTime
lastPing <- IO UTCTime
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.
                            --
                            ByteString
lastResponse <- forall a. a -> IO a
Exception.evaluate (Builder -> ByteString
ByteString.toLazyByteString Builder
builder)

                            MVar ()
event <- forall a. IO (MVar a)
MVar.newEmptyMVar
                            let session :: AutoRefreshSession
session = AutoRefreshSession { UUID
$sel:id:AutoRefreshSession :: UUID
id :: UUID
id, RequestContext -> IO ()
$sel:renderView:AutoRefreshSession :: RequestContext -> IO ()
renderView :: RequestContext -> IO ()
renderView, MVar ()
$sel:event:AutoRefreshSession :: MVar ()
event :: MVar ()
event, Set ByteString
$sel:tables:AutoRefreshSession :: Set ByteString
tables :: Set ByteString
tables, ByteString
$sel:lastResponse:AutoRefreshSession :: ByteString
lastResponse :: ByteString
lastResponse, UTCTime
$sel:lastPing:AutoRefreshSession :: UTCTime
lastPing :: UTCTime
lastPing }
                            forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef AutoRefreshServer
autoRefreshServer (\AutoRefreshServer
s -> AutoRefreshServer
s { $sel:sessions:AutoRefreshServer :: [AutoRefreshSession]
sessions = AutoRefreshSession
sessionforall a. a -> [a] -> [a]
:(forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get forall a. IsLabel "sessions" a => a
#sessions AutoRefreshServer
s) } )
                            forall a. IO a -> IO (Async a)
async (IORef AutoRefreshServer -> IO ()
gcSessions IORef AutoRefreshServer
autoRefreshServer)

                            (?modelContext::ModelContext) =>
IORef (Set ByteString) -> IORef AutoRefreshServer -> IO ()
registerNotificationTrigger ?touchedTables::IORef (Set ByteString)
?touchedTables IORef AutoRefreshServer
autoRefreshServer

                            forall a e. Exception e => e -> a
throw ResponseException
exception
                        Response
_   -> forall a. Text -> a
error Text
"Unimplemented WAI response type."

                (?modelContext::ModelContext) => IO ()
runAction forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Exception.catch` ResponseException -> IO ()
handleResponse
        AutoRefreshEnabled {} -> do
            -- When this function calls the 'action ?theAction' in the other case
            -- we will evaluate this branch
            (?modelContext::ModelContext) => IO ()
runAction

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

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

        [UUID]
availableSessions <- ?applicationContext::ApplicationContext
?applicationContext
                forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get forall a. IsLabel "autoRefreshServer" a => a
#autoRefreshServer
                forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (?context::ControllerContext) =>
IORef AutoRefreshServer -> IO [UUID]
getAvailableSessions

        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (UUID
sessionId forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [UUID]
availableSessions) do
            AutoRefreshSession { RequestContext -> IO ()
renderView :: RequestContext -> IO ()
$sel:renderView:AutoRefreshSession :: AutoRefreshSession -> RequestContext -> IO ()
renderView, MVar ()
event :: MVar ()
$sel:event:AutoRefreshSession :: AutoRefreshSession -> MVar ()
event, ByteString
lastResponse :: ByteString
$sel:lastResponse:AutoRefreshSession :: AutoRefreshSession -> ByteString
lastResponse } <- (?applicationContext::ApplicationContext) =>
UUID -> IO AutoRefreshSession
getSessionById UUID
sessionId

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

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

            forall a. IO a -> IO (Async a)
async forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Applicative f => f a -> f b
forever do
                forall a. MVar a -> IO a
MVar.takeMVar MVar ()
event
                let requestContext :: RequestContext
requestContext = forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get forall a. IsLabel "requestContext" a => a
#requestContext ?context::ControllerContext
?context
                (RequestContext -> IO ()
renderView RequestContext
requestContext) forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` ResponseException -> IO ()
handleResponseException
                forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

            forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

        -- Keep the connection open until it's killed and the onClose is called
        forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (?connection::Connection) => IO DataMessage
receiveDataMessage

    onPing :: (?state::IORef AutoRefreshWSApp, ?context::ControllerContext,
 ?applicationContext::ApplicationContext,
 ?modelContext::ModelContext, ?connection::Connection) =>
IO ()
onPing = do
        UTCTime
now <- IO UTCTime
getCurrentTime
        AutoRefreshActive { UUID
sessionId :: UUID
$sel:sessionId:AwaitingSessionID :: AutoRefreshWSApp -> UUID
sessionId } <- forall state. (?state::IORef state) => IO state
getState
        (?applicationContext::ApplicationContext) =>
UUID -> (AutoRefreshSession -> AutoRefreshSession) -> IO ()
updateSession UUID
sessionId (\AutoRefreshSession
session -> AutoRefreshSession
session { $sel:lastPing:AutoRefreshSession :: UTCTime
lastPing = UTCTime
now })

    onClose :: (?state::IORef AutoRefreshWSApp, ?context::ControllerContext,
 ?applicationContext::ApplicationContext,
 ?modelContext::ModelContext, ?connection::Connection) =>
IO ()
onClose = do
        forall state. (?state::IORef state) => IO state
getState forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            AutoRefreshActive { UUID
sessionId :: UUID
$sel:sessionId:AwaitingSessionID :: AutoRefreshWSApp -> UUID
sessionId } -> do
                let autoRefreshServer :: IORef AutoRefreshServer
autoRefreshServer = ?applicationContext::ApplicationContext
?applicationContext forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get forall a. IsLabel "autoRefreshServer" a => a
#autoRefreshServer
                forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef AutoRefreshServer
autoRefreshServer (\AutoRefreshServer
server -> AutoRefreshServer
server { $sel:sessions:AutoRefreshServer :: [AutoRefreshSession]
sessions = forall a. (a -> Bool) -> [a] -> [a]
filter (\AutoRefreshSession { UUID
id :: UUID
$sel:id:AutoRefreshSession :: AutoRefreshSession -> UUID
id } -> UUID
id forall a. Eq a => a -> a -> Bool
/= UUID
sessionId) (forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get forall a. IsLabel "sessions" a => a
#sessions AutoRefreshServer
server) })
            AutoRefreshWSApp
AwaitingSessionID -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


registerNotificationTrigger :: (?modelContext :: ModelContext) => IORef (Set ByteString) -> IORef AutoRefreshServer -> IO ()
registerNotificationTrigger :: (?modelContext::ModelContext) =>
IORef (Set ByteString) -> IORef AutoRefreshServer -> IO ()
registerNotificationTrigger IORef (Set ByteString)
touchedTablesVar IORef AutoRefreshServer
autoRefreshServer = do
    [ByteString]
touchedTables <- forall a. Set a -> [a]
Set.toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
readIORef IORef (Set ByteString)
touchedTablesVar
    Set ByteString
subscribedTables <- (forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get forall a. IsLabel "subscribedTables" a => a
#subscribedTables) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (IORef AutoRefreshServer
autoRefreshServer forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall a. IORef a -> IO a
readIORef)

    let subscriptionRequired :: [ByteString]
subscriptionRequired = [ByteString]
touchedTables forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall a. (a -> Bool) -> [a] -> [a]
filter (\ByteString
table -> Set ByteString
subscribedTables forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall a. Ord a => a -> Set a -> Bool
Set.notMember ByteString
table)
    forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef AutoRefreshServer
autoRefreshServer (\AutoRefreshServer
server -> AutoRefreshServer
server { $sel:subscribedTables:AutoRefreshServer :: Set ByteString
subscribedTables = forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get forall a. IsLabel "subscribedTables" a => a
#subscribedTables AutoRefreshServer
server forall a. Semigroup a => a -> a -> a
<> forall a. Ord a => [a] -> Set a
Set.fromList [ByteString]
subscriptionRequired })

    PGListener
pgListener <- forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get forall a. IsLabel "pgListener" a => a
#pgListener forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
readIORef IORef AutoRefreshServer
autoRefreshServer
    [Subscription]
subscriptions <-  [ByteString]
subscriptionRequired forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ByteString
table -> do
        let createTriggerSql :: Query
createTriggerSql = ByteString -> Query
notificationTrigger ByteString
table

        -- We need to add the trigger from the main IHP database role other we will get this error:
        -- ERROR:  permission denied for schema public
        forall a.
(?modelContext::ModelContext) =>
((?modelContext::ModelContext) => IO a) -> IO a
withRowLevelSecurityDisabled do
            forall q.
(?modelContext::ModelContext, ToRow q) =>
Query -> q -> IO Int64
sqlExec Query
createTriggerSql ()

        PGListener
pgListener forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> ByteString -> Callback -> PGListener -> IO Subscription
PGListener.subscribe (ByteString -> ByteString
channelName ByteString
table) \Notification
notification -> do
                [AutoRefreshSession]
sessions <- (forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get forall a. IsLabel "sessions" a => a
#sessions) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
readIORef IORef AutoRefreshServer
autoRefreshServer
                [AutoRefreshSession]
sessions
                    forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall a. (a -> Bool) -> [a] -> [a]
filter (\AutoRefreshSession
session -> ByteString
table forall a. Ord a => a -> Set a -> Bool
`Set.member` (forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get forall a. IsLabel "tables" a => a
#tables AutoRefreshSession
session))
                    forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall a b. (a -> b) -> [a] -> [b]
map (\AutoRefreshSession
session -> forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get forall a. IsLabel "event" a => a
#event AutoRefreshSession
session)
                    forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\MVar ()
event -> forall a. MVar a -> a -> IO Bool
MVar.tryPutMVar MVar ()
event ())
                forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
    forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef AutoRefreshServer
autoRefreshServer (\AutoRefreshServer
s -> AutoRefreshServer
s { $sel:subscriptions:AutoRefreshServer :: [Subscription]
subscriptions = forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get forall a. IsLabel "subscriptions" a => a
#subscriptions AutoRefreshServer
s forall a. Semigroup a => a -> a -> a
<> [Subscription]
subscriptions })
    forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Returns the ids of all sessions available to the client based on what sessions are found in the session cookie
getAvailableSessions :: (?context :: ControllerContext) => IORef AutoRefreshServer -> IO [UUID]
getAvailableSessions :: (?context::ControllerContext) =>
IORef AutoRefreshServer -> IO [UUID]
getAvailableSessions IORef AutoRefreshServer
autoRefreshServer = do
    [AutoRefreshSession]
allSessions <- (forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get forall a. IsLabel "sessions" a => a
#sessions) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
readIORef IORef AutoRefreshServer
autoRefreshServer
    Text
text <- forall a. a -> Maybe a -> a
fromMaybe Text
"" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall value.
(?context::ControllerContext, Serialize value) =>
ByteString -> IO (Maybe value)
getSession ByteString
"autoRefreshSessions"
    let uuidCharCount :: Int
uuidCharCount = Text -> Int
Text.length (UUID -> Text
UUID.toText UUID
UUID.nil)
    let allSessionIds :: [UUID]
allSessionIds = forall a b. (a -> b) -> [a] -> [b]
map (forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get forall a. IsLabel "id" a => a
#id) [AutoRefreshSession]
allSessions
    Text
text
        forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> Int -> Text -> [Text]
Text.chunksOf Int
uuidCharCount
        forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Text -> Maybe UUID
UUID.fromText
        forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall a. (a -> Bool) -> [a] -> [a]
filter (\UUID
id -> UUID
id forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [UUID]
allSessionIds)
        forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Returns a session for a given session id. Errors in case the session does not exist.
getSessionById :: (?applicationContext :: ApplicationContext) => UUID -> IO AutoRefreshSession
getSessionById :: (?applicationContext::ApplicationContext) =>
UUID -> IO AutoRefreshSession
getSessionById UUID
sessionId = do
    AutoRefreshServer
autoRefreshServer <- ?applicationContext::ApplicationContext
?applicationContext
            forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get forall a. IsLabel "autoRefreshServer" a => a
#autoRefreshServer
            forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall a. IORef a -> IO a
readIORef
    AutoRefreshServer
autoRefreshServer
        forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get forall a. IsLabel "sessions" a => a
#sessions
        forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\AutoRefreshSession { UUID
id :: UUID
$sel:id:AutoRefreshSession :: AutoRefreshSession -> UUID
id } -> UUID
id forall a. Eq a => a -> a -> Bool
== UUID
sessionId)
        forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall a. a -> Maybe a -> a
Maybe.fromMaybe (forall a. Text -> a
error Text
"getSessionById: Could not find the session")
        forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Applies a update function to a session specified by its session id
updateSession :: (?applicationContext :: ApplicationContext) => UUID -> (AutoRefreshSession -> AutoRefreshSession) -> IO ()
updateSession :: (?applicationContext::ApplicationContext) =>
UUID -> (AutoRefreshSession -> AutoRefreshSession) -> IO ()
updateSession UUID
sessionId AutoRefreshSession -> AutoRefreshSession
updateFunction = do
    let server :: IORef AutoRefreshServer
server = ?applicationContext::ApplicationContext
?applicationContext forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get forall a. IsLabel "autoRefreshServer" a => a
#autoRefreshServer
    let updateSession' :: AutoRefreshSession -> AutoRefreshSession
updateSession' AutoRefreshSession
session = if forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get forall a. IsLabel "id" a => a
#id AutoRefreshSession
session forall a. Eq a => a -> a -> Bool
== UUID
sessionId then AutoRefreshSession -> AutoRefreshSession
updateFunction AutoRefreshSession
session else AutoRefreshSession
session
    forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef AutoRefreshServer
server (\AutoRefreshServer
server -> AutoRefreshServer
server { $sel:sessions:AutoRefreshServer :: [AutoRefreshSession]
sessions = forall a b. (a -> b) -> [a] -> [b]
map AutoRefreshSession -> AutoRefreshSession
updateSession' (forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get forall a. IsLabel "sessions" a => a
#sessions AutoRefreshServer
server) })
    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
    UTCTime
now <- IO UTCTime
getCurrentTime
    forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef AutoRefreshServer
autoRefreshServer (\AutoRefreshServer
autoRefreshServer -> AutoRefreshServer
autoRefreshServer { $sel:sessions:AutoRefreshServer :: [AutoRefreshSession]
sessions = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. UTCTime -> AutoRefreshSession -> Bool
isSessionExpired UTCTime
now) (forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get forall a. IsLabel "sessions" a => a
#sessions AutoRefreshServer
autoRefreshServer) })

-- | 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 :: UTCTime
$sel:lastPing:AutoRefreshSession :: AutoRefreshSession -> UTCTime
lastPing } = (UTCTime
now UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
lastPing) 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 :: ByteString -> ByteString
channelName :: ByteString -> ByteString
channelName ByteString
tableName = ByteString
"did_change_" forall a. Semigroup a => a -> a -> a
<> ByteString
tableName

-- | Returns the sql code to set up a database trigger
notificationTrigger :: ByteString -> PG.Query
notificationTrigger :: ByteString -> Query
notificationTrigger ByteString
tableName = ByteString -> Query
PG.Query [i|
        BEGIN;
            CREATE OR REPLACE FUNCTION #{functionName}() RETURNS TRIGGER AS $$
                BEGIN
                    PERFORM pg_notify('#{channelName tableName}', '');
                    RETURN new;
                END;
            $$ language plpgsql;
            DROP TRIGGER IF EXISTS #{insertTriggerName} ON #{tableName};
            CREATE TRIGGER #{insertTriggerName} AFTER INSERT ON "#{tableName}" FOR EACH STATEMENT EXECUTE PROCEDURE #{functionName}();
            
            DROP TRIGGER IF EXISTS #{updateTriggerName} ON #{tableName};
            CREATE TRIGGER #{updateTriggerName} AFTER UPDATE ON "#{tableName}" FOR EACH STATEMENT EXECUTE PROCEDURE #{functionName}();

            DROP TRIGGER IF EXISTS #{deleteTriggerName} ON #{tableName};
            CREATE TRIGGER #{deleteTriggerName} AFTER DELETE ON "#{tableName}" FOR EACH STATEMENT EXECUTE PROCEDURE #{functionName}();
        
        COMMIT;
    |]
    where
        functionName :: ByteString
functionName = ByteString
"notify_did_change_" forall a. Semigroup a => a -> a -> a
<> ByteString
tableName
        insertTriggerName :: ByteString
insertTriggerName = ByteString
"did_insert_" forall a. Semigroup a => a -> a -> a
<> ByteString
tableName
        updateTriggerName :: ByteString
updateTriggerName = ByteString
"did_update_" forall a. Semigroup a => a -> a -> a
<> ByteString
tableName
        deleteTriggerName :: ByteString
deleteTriggerName = ByteString
"did_delete_" forall a. Semigroup a => a -> a -> a
<> ByteString
tableName