{-|
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 IHP.Controller.Response 
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
    AutoRefreshState -> IO ()
forall value.
(?context::ControllerContext, Typeable value) =>
value -> IO ()
putContext AutoRefreshState
AutoRefreshDisabled
    IORef AutoRefreshServer -> IO ()
forall value.
(?context::ControllerContext, Typeable value) =>
value -> IO ()
putContext ?applicationContext::ApplicationContext
ApplicationContext
?applicationContext.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]
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
ControllerContext
?context

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

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

            (?modelContext::ModelContext) =>
((?modelContext::ModelContext,
  ?touchedTables::IORef (Set ByteString)) =>
 IO ())
-> IO ()
((?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 <- IORef (Set ByteString) -> IO (Set ByteString)
forall a. IORef a -> IO a
readIORef ?touchedTables::IORef (Set ByteString)
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.
                            --
                            LazyByteString
lastResponse <- LazyByteString -> IO LazyByteString
forall a. a -> IO a
Exception.evaluate (Builder -> LazyByteString
ByteString.toLazyByteString Builder
builder)

                            MVar ()
event <- IO (MVar ())
forall a. IO (MVar a)
MVar.newEmptyMVar
                            let session :: AutoRefreshSession
session = AutoRefreshSession { UUID
id :: UUID
id :: UUID
id, RequestContext -> IO ()
renderView :: RequestContext -> IO ()
renderView :: RequestContext -> IO ()
renderView, MVar ()
event :: MVar ()
event :: MVar ()
event, Set ByteString
tables :: Set ByteString
tables :: Set ByteString
tables, LazyByteString
lastResponse :: LazyByteString
lastResponse :: LazyByteString
lastResponse, UTCTime
lastPing :: UTCTime
lastPing :: UTCTime
lastPing }
                            IORef AutoRefreshServer
-> (AutoRefreshServer -> AutoRefreshServer) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef AutoRefreshServer
autoRefreshServer (\AutoRefreshServer
s -> AutoRefreshServer
s { sessions = session:s.sessions } )
                            IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IORef AutoRefreshServer -> IO ()
gcSessions IORef AutoRefreshServer
autoRefreshServer)

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

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

                IO ()
(?modelContext::ModelContext) => IO ()
runAction IO () -> (ResponseException -> IO ()) -> IO ()
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
            IO ()
(?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
        AutoRefreshWSApp -> IO ()
forall state. (?state::IORef state) => state -> IO ()
setState AutoRefreshActive { UUID
sessionId :: UUID
sessionId :: UUID
sessionId }

        [UUID]
availableSessions <- (?context::ControllerContext) =>
IORef AutoRefreshServer -> IO [UUID]
IORef AutoRefreshServer -> IO [UUID]
getAvailableSessions ?applicationContext::ApplicationContext
ApplicationContext
?applicationContext.autoRefreshServer

        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (UUID
sessionId UUID -> [UUID] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [UUID]
availableSessions) do
            AutoRefreshSession { RequestContext -> IO ()
renderView :: AutoRefreshSession -> RequestContext -> IO ()
renderView :: RequestContext -> IO ()
renderView, MVar ()
event :: AutoRefreshSession -> MVar ()
event :: MVar ()
event, LazyByteString
lastResponse :: AutoRefreshSession -> LazyByteString
lastResponse :: LazyByteString
lastResponse } <- (?applicationContext::ApplicationContext) =>
UUID -> IO AutoRefreshSession
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 :: 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
                            (?applicationContext::ApplicationContext) =>
UUID -> (AutoRefreshSession -> AutoRefreshSession) -> IO ()
UUID -> (AutoRefreshSession -> AutoRefreshSession) -> IO ()
updateSession UUID
sessionId (\AutoRefreshSession
session -> AutoRefreshSession
session { lastResponse = html })
                    Response
_   -> Text -> IO ()
forall a. Text -> a
error Text
"Unimplemented WAI response type."

            IO Any -> IO (Async Any)
forall a. IO a -> IO (Async a)
async (IO Any -> IO (Async Any)) -> IO Any -> IO (Async Any)
forall a b. (a -> b) -> a -> b
$ IO () -> IO Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever do
                MVar () -> IO ()
forall a. MVar a -> IO a
MVar.takeMVar MVar ()
event
                let requestContext :: RequestContext
requestContext = ?context::ControllerContext
ControllerContext
?context.requestContext
                (RequestContext -> IO ()
renderView RequestContext
requestContext) IO () -> (ResponseException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` ResponseException -> IO ()
handleResponseException
                () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

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

        -- Keep the connection open until it's killed and the onClose is called
        IO DataMessage -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever IO DataMessage
(?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 :: AutoRefreshWSApp -> UUID
sessionId :: UUID
sessionId } <- IO AutoRefreshWSApp
forall state. (?state::IORef state) => IO state
getState
        (?applicationContext::ApplicationContext) =>
UUID -> (AutoRefreshSession -> AutoRefreshSession) -> IO ()
UUID -> (AutoRefreshSession -> AutoRefreshSession) -> IO ()
updateSession UUID
sessionId (\AutoRefreshSession
session -> AutoRefreshSession
session { lastPing = now })

    onClose :: (?state::IORef AutoRefreshWSApp, ?context::ControllerContext,
 ?applicationContext::ApplicationContext,
 ?modelContext::ModelContext, ?connection::Connection) =>
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
                let autoRefreshServer :: IORef AutoRefreshServer
autoRefreshServer = ?applicationContext::ApplicationContext
ApplicationContext
?applicationContext.autoRefreshServer
                IORef AutoRefreshServer
-> (AutoRefreshServer -> AutoRefreshServer) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef AutoRefreshServer
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) => 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 <- Set ByteString -> [ByteString]
forall a. Set a -> [a]
Set.toList (Set ByteString -> [ByteString])
-> IO (Set ByteString) -> IO [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Set ByteString) -> IO (Set ByteString)
forall a. IORef a -> IO a
readIORef IORef (Set ByteString)
touchedTablesVar
    Set ByteString
subscribedTables <- (.subscribedTables) (AutoRefreshServer -> Set ByteString)
-> IO AutoRefreshServer -> IO (Set ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (IORef AutoRefreshServer
autoRefreshServer IORef AutoRefreshServer
-> (IORef AutoRefreshServer -> IO AutoRefreshServer)
-> IO AutoRefreshServer
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> IORef AutoRefreshServer -> IO AutoRefreshServer
forall a. IORef a -> IO a
readIORef)

    let subscriptionRequired :: [ByteString]
subscriptionRequired = [ByteString]
touchedTables [ByteString] -> ([ByteString] -> [ByteString]) -> [ByteString]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (ByteString -> Bool) -> [ByteString] -> [ByteString]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ByteString
table -> Set ByteString
subscribedTables Set ByteString -> (Set ByteString -> Bool) -> Bool
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> ByteString -> Set ByteString -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember ByteString
table)
    IORef AutoRefreshServer
-> (AutoRefreshServer -> AutoRefreshServer) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef AutoRefreshServer
autoRefreshServer (\AutoRefreshServer
server -> AutoRefreshServer
server { subscribedTables = server.subscribedTables <> Set.fromList subscriptionRequired })

    PGListener
pgListener <- (.pgListener) (AutoRefreshServer -> PGListener)
-> IO AutoRefreshServer -> IO PGListener
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
    [Subscription]
subscriptions <-  [ByteString]
subscriptionRequired [ByteString]
-> ([ByteString] -> IO [Subscription]) -> IO [Subscription]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (ByteString -> IO Subscription)
-> [ByteString] -> IO [Subscription]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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
        ((?modelContext::ModelContext) => IO Int64) -> IO Int64
forall a.
(?modelContext::ModelContext) =>
((?modelContext::ModelContext) => IO a) -> IO a
withRowLevelSecurityDisabled do
            Query -> () -> IO Int64
forall q.
(?modelContext::ModelContext, ToRow q) =>
Query -> q -> IO Int64
sqlExec Query
createTriggerSql ()

        PGListener
pgListener PGListener -> (PGListener -> IO Subscription) -> IO Subscription
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> ByteString -> Callback -> PGListener -> IO Subscription
PGListener.subscribe (ByteString -> ByteString
channelName ByteString
table) \Notification
notification -> do
                [AutoRefreshSession]
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
                [AutoRefreshSession]
sessions
                    [AutoRefreshSession]
-> ([AutoRefreshSession] -> [AutoRefreshSession])
-> [AutoRefreshSession]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (AutoRefreshSession -> Bool)
-> [AutoRefreshSession] -> [AutoRefreshSession]
forall a. (a -> Bool) -> [a] -> [a]
filter (\AutoRefreshSession
session -> ByteString
table ByteString -> Set ByteString -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` AutoRefreshSession
session.tables)
                    [AutoRefreshSession]
-> ([AutoRefreshSession] -> [MVar ()]) -> [MVar ()]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (AutoRefreshSession -> MVar ())
-> [AutoRefreshSession] -> [MVar ()]
forall a b. (a -> b) -> [a] -> [b]
map (\AutoRefreshSession
session -> AutoRefreshSession
session.event)
                    [MVar ()] -> ([MVar ()] -> IO [Bool]) -> IO [Bool]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (MVar () -> IO Bool) -> [MVar ()] -> IO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\MVar ()
event -> MVar () -> () -> IO Bool
forall a. MVar a -> a -> IO Bool
MVar.tryPutMVar MVar ()
event ())
                () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
    IORef AutoRefreshServer
-> (AutoRefreshServer -> AutoRefreshServer) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef AutoRefreshServer
autoRefreshServer (\AutoRefreshServer
s -> AutoRefreshServer
s { subscriptions = s.subscriptions <> subscriptions })
    () -> IO ()
forall a. a -> IO a
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 <- (.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
text <- Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Maybe Text -> Text) -> IO (Maybe Text) -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> IO (Maybe Text)
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 = (AutoRefreshSession -> UUID) -> [AutoRefreshSession] -> [UUID]
forall a b. (a -> b) -> [a] -> [b]
map (.id) [AutoRefreshSession]
allSessions
    Text
text
        Text -> (Text -> [Text]) -> [Text]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> Int -> Text -> [Text]
Text.chunksOf Int
uuidCharCount
        [Text] -> ([Text] -> [UUID]) -> [UUID]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (Text -> Maybe UUID) -> [Text] -> [UUID]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Text -> Maybe UUID
UUID.fromText
        [UUID] -> ([UUID] -> [UUID]) -> [UUID]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (UUID -> Bool) -> [UUID] -> [UUID]
forall a. (a -> Bool) -> [a] -> [a]
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)
        [UUID] -> ([UUID] -> IO [UUID]) -> IO [UUID]
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> [UUID] -> IO [UUID]
forall a. a -> IO a
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 <- IORef AutoRefreshServer -> IO AutoRefreshServer
forall a. IORef a -> IO a
readIORef ?applicationContext::ApplicationContext
ApplicationContext
?applicationContext.autoRefreshServer
    AutoRefreshServer
autoRefreshServer.sessions
        [AutoRefreshSession]
-> ([AutoRefreshSession] -> Maybe AutoRefreshSession)
-> Maybe AutoRefreshSession
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> (AutoRefreshSession -> Bool)
-> [AutoRefreshSession] -> Maybe AutoRefreshSession
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\AutoRefreshSession { UUID
id :: AutoRefreshSession -> UUID
id :: UUID
id } -> UUID
id UUID -> UUID -> Bool
forall a. Eq a => a -> a -> Bool
== UUID
sessionId)
        Maybe AutoRefreshSession
-> (Maybe AutoRefreshSession -> AutoRefreshSession)
-> AutoRefreshSession
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> AutoRefreshSession
-> Maybe AutoRefreshSession -> AutoRefreshSession
forall a. a -> Maybe a -> a
Maybe.fromMaybe (Text -> AutoRefreshSession
forall a. Text -> a
error Text
"getSessionById: Could not find the session")
        AutoRefreshSession
-> (AutoRefreshSession -> IO AutoRefreshSession)
-> IO AutoRefreshSession
forall {t1} {t2}. t1 -> (t1 -> t2) -> t2
|> AutoRefreshSession -> IO AutoRefreshSession
forall a. a -> IO a
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
?applicationContext.autoRefreshServer
    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
    UTCTime
now <- IO UTCTime
getCurrentTime
    IORef AutoRefreshServer
-> (AutoRefreshServer -> AutoRefreshServer) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef AutoRefreshServer
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 :: ByteString -> ByteString
channelName :: ByteString -> ByteString
channelName ByteString
tableName = ByteString
"ar_did_change_" ByteString -> ByteString -> ByteString
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
"ar_notify_did_change_" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
tableName
        insertTriggerName :: ByteString
insertTriggerName = ByteString
"ar_did_insert_" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
tableName
        updateTriggerName :: ByteString
updateTriggerName = ByteString
"ar_did_update_" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
tableName
        deleteTriggerName :: ByteString
deleteTriggerName = ByteString
"ar_did_delete_" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
tableName