{-|
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 :: 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 ApplicationContext
-> (ApplicationContext -> IORef AutoRefreshServer)
-> IORef AutoRefreshServer
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "autoRefreshServer"
-> ApplicationContext -> IORef AutoRefreshServer
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "autoRefreshServer" (Proxy "autoRefreshServer")
Proxy "autoRefreshServer"
#autoRefreshServer)

autoRefresh :: (
    ?theAction :: action
    , Controller action
    , ?modelContext :: ModelContext
    , ?context :: ControllerContext
    ) => ((?modelContext :: ModelContext) => IO ()) -> IO ()
autoRefresh :: ((?modelContext::ModelContext) => IO ()) -> IO ()
autoRefresh (?modelContext::ModelContext) => IO ()
runAction = do
    AutoRefreshState
autoRefreshState <- (?context::ControllerContext, Typeable AutoRefreshState) =>
IO AutoRefreshState
forall value.
(?context::ControllerContext, Typeable value) =>
IO value
fromContext @AutoRefreshState
    IORef AutoRefreshServer
autoRefreshServer <- (?context::ControllerContext,
 Typeable (IORef AutoRefreshServer)) =>
IO (IORef 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 { 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.
                            --
                            ByteString
lastResponse <- ByteString -> IO ByteString
forall a. a -> IO a
Exception.evaluate (Builder -> ByteString
ByteString.toLazyByteString Builder
builder)

                            MVar ()
event <- IO (MVar ())
forall a. IO (MVar a)
MVar.newEmptyMVar
                            let session :: AutoRefreshSession
session = AutoRefreshSession :: UUID
-> (RequestContext -> IO ())
-> MVar ()
-> Set ByteString
-> ByteString
-> UTCTime
-> AutoRefreshSession
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 }
                            IORef AutoRefreshServer
-> (AutoRefreshServer -> AutoRefreshServer) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef AutoRefreshServer
autoRefreshServer (\AutoRefreshServer
s -> AutoRefreshServer
s { $sel:sessions:AutoRefreshServer :: [AutoRefreshSession]
sessions = AutoRefreshSession
sessionAutoRefreshSession -> [AutoRefreshSession] -> [AutoRefreshSession]
forall a. a -> [a] -> [a]
:(Proxy "sessions" -> AutoRefreshServer -> [AutoRefreshSession]
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "sessions" (Proxy "sessions")
Proxy "sessions"
#sessions AutoRefreshServer
s) } )
                            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 :: IO ()
run = do
        UUID
sessionId <- (?connection::Connection, WebSocketsData UUID) => IO UUID
forall a. (?connection::Connection, WebSocketsData a) => IO a
receiveData @UUID
        AutoRefreshWSApp -> IO ()
forall state. (?state::IORef state) => state -> IO ()
setState AutoRefreshActive :: UUID -> AutoRefreshWSApp
AutoRefreshActive { UUID
sessionId :: UUID
$sel:sessionId:AwaitingSessionID :: UUID
sessionId }

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

        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (UUID
sessionId UUID -> [UUID] -> Bool
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
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

                        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
html ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
lastResponse) do
                            ByteString -> IO ()
forall text.
(?connection::Connection, WebSocketsData text) =>
text -> IO ()
sendTextData ByteString
html
                            (?applicationContext::ApplicationContext) =>
UUID -> (AutoRefreshSession -> AutoRefreshSession) -> IO ()
UUID -> (AutoRefreshSession -> AutoRefreshSession) -> IO ()
updateSession UUID
sessionId (\AutoRefreshSession
session -> AutoRefreshSession
session { $sel:lastResponse:AutoRefreshSession :: ByteString
lastResponse = ByteString
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 = Proxy "requestContext" -> ControllerContext -> RequestContext
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "requestContext" (Proxy "requestContext")
Proxy "requestContext"
#requestContext ?context::ControllerContext
ControllerContext
?context
                (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 (f :: * -> *) a. Applicative f => a -> f a
pure ()

            () -> IO ()
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 :: IO ()
onPing = do
        UTCTime
now <- IO UTCTime
getCurrentTime
        AutoRefreshActive { UUID
sessionId :: UUID
$sel:sessionId:AwaitingSessionID :: AutoRefreshWSApp -> 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 { $sel:lastPing:AutoRefreshSession :: UTCTime
lastPing = UTCTime
now })

    onClose :: IO ()
onClose = do
        IO AutoRefreshWSApp
forall state. (?state::IORef state) => IO state
getState IO AutoRefreshWSApp -> (AutoRefreshWSApp -> IO ()) -> IO ()
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
?applicationContext ApplicationContext
-> (ApplicationContext -> IORef AutoRefreshServer)
-> IORef AutoRefreshServer
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "autoRefreshServer"
-> ApplicationContext -> IORef AutoRefreshServer
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "autoRefreshServer" (Proxy "autoRefreshServer")
Proxy "autoRefreshServer"
#autoRefreshServer
                IORef AutoRefreshServer
-> (AutoRefreshServer -> AutoRefreshServer) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef AutoRefreshServer
autoRefreshServer (\AutoRefreshServer
server -> AutoRefreshServer
server { $sel:sessions:AutoRefreshServer :: [AutoRefreshSession]
sessions = (AutoRefreshSession -> Bool)
-> [AutoRefreshSession] -> [AutoRefreshSession]
forall a. (a -> Bool) -> [a] -> [a]
filter (\AutoRefreshSession { UUID
id :: UUID
$sel:id:AutoRefreshSession :: AutoRefreshSession -> UUID
id } -> UUID
id UUID -> UUID -> Bool
forall a. Eq a => a -> a -> Bool
/= UUID
sessionId) (Proxy "sessions" -> AutoRefreshServer -> [AutoRefreshSession]
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "sessions" (Proxy "sessions")
Proxy "sessions"
#sessions AutoRefreshServer
server) })
            AutoRefreshWSApp
AwaitingSessionID -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()


registerNotificationTrigger :: (?modelContext :: ModelContext) => IORef (Set ByteString) -> IORef AutoRefreshServer -> IO ()
registerNotificationTrigger :: 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 <- (Proxy "subscribedTables" -> AutoRefreshServer -> Set ByteString
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "subscribedTables" (Proxy "subscribedTables")
Proxy "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 { $sel:subscribedTables:AutoRefreshServer :: Set ByteString
subscribedTables = Proxy "subscribedTables" -> AutoRefreshServer -> Set ByteString
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "subscribedTables" (Proxy "subscribedTables")
Proxy "subscribedTables"
#subscribedTables AutoRefreshServer
server Set ByteString -> Set ByteString -> Set ByteString
forall a. Semigroup a => a -> a -> a
<> [ByteString] -> Set ByteString
forall a. Ord a => [a] -> Set a
Set.fromList [ByteString]
subscriptionRequired })

    PGListener
pgListener <- Proxy "pgListener" -> AutoRefreshServer -> PGListener
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "pgListener" (Proxy "pgListener")
Proxy "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)
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, Show 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 <- (Proxy "sessions" -> AutoRefreshServer -> [AutoRefreshSession]
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "sessions" (Proxy "sessions")
Proxy "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` (Proxy "tables" -> AutoRefreshSession -> Set ByteString
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "tables" (Proxy "tables")
Proxy "tables"
#tables AutoRefreshSession
session))
                    [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 -> Proxy "event" -> AutoRefreshSession -> MVar ()
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "event" (Proxy "event")
Proxy "event"
#event AutoRefreshSession
session)
                    [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)
mapM (\MVar ()
event -> MVar () -> () -> IO Bool
forall a. MVar a -> a -> IO Bool
MVar.tryPutMVar MVar ()
event ())
                () -> IO ()
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 { $sel:subscriptions:AutoRefreshServer :: [Subscription]
subscriptions = Proxy "subscriptions" -> AutoRefreshServer -> [Subscription]
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "subscriptions" (Proxy "subscriptions")
Proxy "subscriptions"
#subscriptions AutoRefreshServer
s [Subscription] -> [Subscription] -> [Subscription]
forall a. Semigroup a => a -> a -> a
<> [Subscription]
subscriptions })
    () -> IO ()
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 :: IORef AutoRefreshServer -> IO [UUID]
getAvailableSessions IORef AutoRefreshServer
autoRefreshServer = do
    [AutoRefreshSession]
allSessions <- (Proxy "sessions" -> AutoRefreshServer -> [AutoRefreshSession]
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "sessions" (Proxy "sessions")
Proxy "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
    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 (Proxy "id" -> AutoRefreshSession -> UUID
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "id" (Proxy "id")
Proxy "id"
#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 (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 (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 :: UUID -> IO AutoRefreshSession
getSessionById UUID
sessionId = do
    AutoRefreshServer
autoRefreshServer <- ?applicationContext::ApplicationContext
ApplicationContext
?applicationContext
            ApplicationContext
-> (ApplicationContext -> IORef AutoRefreshServer)
-> IORef AutoRefreshServer
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "autoRefreshServer"
-> ApplicationContext -> IORef AutoRefreshServer
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "autoRefreshServer" (Proxy "autoRefreshServer")
Proxy "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
    AutoRefreshServer
autoRefreshServer
        AutoRefreshServer
-> (AutoRefreshServer -> [AutoRefreshSession])
-> [AutoRefreshSession]
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "sessions" -> AutoRefreshServer -> [AutoRefreshSession]
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "sessions" (Proxy "sessions")
Proxy "sessions"
#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 :: UUID
$sel:id:AutoRefreshSession :: AutoRefreshSession -> 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 (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 :: UUID -> (AutoRefreshSession -> AutoRefreshSession) -> IO ()
updateSession UUID
sessionId AutoRefreshSession -> AutoRefreshSession
updateFunction = do
    let server :: IORef AutoRefreshServer
server = ?applicationContext::ApplicationContext
ApplicationContext
?applicationContext ApplicationContext
-> (ApplicationContext -> IORef AutoRefreshServer)
-> IORef AutoRefreshServer
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> Proxy "autoRefreshServer"
-> ApplicationContext -> IORef AutoRefreshServer
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "autoRefreshServer" (Proxy "autoRefreshServer")
Proxy "autoRefreshServer"
#autoRefreshServer
    let updateSession' :: AutoRefreshSession -> AutoRefreshSession
updateSession' AutoRefreshSession
session = if Proxy "id" -> AutoRefreshSession -> UUID
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "id" (Proxy "id")
Proxy "id"
#id AutoRefreshSession
session 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 { $sel:sessions:AutoRefreshServer :: [AutoRefreshSession]
sessions = (AutoRefreshSession -> AutoRefreshSession)
-> [AutoRefreshSession] -> [AutoRefreshSession]
forall a b. (a -> b) -> [a] -> [b]
map AutoRefreshSession -> AutoRefreshSession
updateSession' (Proxy "sessions" -> AutoRefreshServer -> [AutoRefreshSession]
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "sessions" (Proxy "sessions")
Proxy "sessions"
#sessions AutoRefreshServer
server) })
    () -> IO ()
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 { $sel:sessions:AutoRefreshServer :: [AutoRefreshSession]
sessions = (AutoRefreshSession -> Bool)
-> [AutoRefreshSession] -> [AutoRefreshSession]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (AutoRefreshSession -> Bool) -> AutoRefreshSession -> Bool
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) (Proxy "sessions" -> AutoRefreshServer -> [AutoRefreshSession]
forall model (name :: Symbol) value.
(KnownSymbol name, HasField name model value) =>
Proxy name -> model -> value
get IsLabel "sessions" (Proxy "sessions")
Proxy "sessions"
#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) 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
"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
"notify_did_change_" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
tableName
        insertTriggerName :: ByteString
insertTriggerName = ByteString
"did_insert_" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
tableName
        updateTriggerName :: ByteString
updateTriggerName = ByteString
"did_update_" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
tableName
        deleteTriggerName :: ByteString
deleteTriggerName = ByteString
"did_delete_" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
tableName