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
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)
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
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
(?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 ()
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
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 ()
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
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
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 ()
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) })
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)
channelName :: ByteString -> ByteString
channelName :: ByteString -> ByteString
channelName ByteString
tableName = ByteString
"did_change_" forall a. Semigroup a => a -> a -> a
<> ByteString
tableName
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