Fix dropping schema cache reload notifications
* test: bad schema reload * refactor: DRY using the "extra" lib * refactor: move worker funtions inside AppState * Also rename Workers.hs to Admin.hs
This commit is contained in:
Steve Chavez
@@ -0,0 +1,87 @@
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module PostgREST.Admin
|
||||
( runAdmin
|
||||
) where
|
||||
|
||||
import qualified Data.Text as T
|
||||
import qualified Hasql.Session as SQL
|
||||
import qualified Network.HTTP.Types.Status as HTTP
|
||||
import qualified Network.Wai as Wai
|
||||
import qualified Network.Wai.Handler.Warp as Warp
|
||||
|
||||
import Control.Monad.Extra (whenJust)
|
||||
|
||||
import Network.Socket
|
||||
import Network.Socket.ByteString
|
||||
|
||||
import PostgREST.AppState (AppState)
|
||||
import PostgREST.Config (AppConfig (..))
|
||||
|
||||
import qualified PostgREST.AppState as AppState
|
||||
|
||||
import Protolude
|
||||
|
||||
runAdmin :: AppConfig -> AppState -> Warp.Settings -> IO ()
|
||||
runAdmin conf@AppConfig{configAdminServerPort} appState settings =
|
||||
whenJust configAdminServerPort $ \adminPort -> do
|
||||
AppState.logWithZTime appState $ "Admin server listening on port " <> show adminPort
|
||||
void . forkIO $ Warp.runSettings (settings & Warp.setPort adminPort) adminApp
|
||||
where
|
||||
adminApp = admin appState conf
|
||||
|
||||
-- | PostgREST admin application
|
||||
admin :: AppState.AppState -> AppConfig -> Wai.Application
|
||||
admin appState appConfig req respond = do
|
||||
isMainAppReachable <- any isRight <$> reachMainApp appConfig
|
||||
isSchemaCacheLoaded <- isJust <$> AppState.getSchemaCache appState
|
||||
isConnectionUp <-
|
||||
if configDbChannelEnabled appConfig
|
||||
then AppState.getIsListenerOn appState
|
||||
else isRight <$> AppState.usePool appState (SQL.sql "SELECT 1")
|
||||
|
||||
case Wai.pathInfo req of
|
||||
["ready"] ->
|
||||
respond $ Wai.responseLBS (if isMainAppReachable && isConnectionUp && isSchemaCacheLoaded then HTTP.status200 else HTTP.status503) [] mempty
|
||||
["live"] ->
|
||||
respond $ Wai.responseLBS (if isMainAppReachable then HTTP.status200 else HTTP.status503) [] mempty
|
||||
_ ->
|
||||
respond $ Wai.responseLBS HTTP.status404 [] mempty
|
||||
|
||||
-- Try to connect to the main app socket
|
||||
-- Note that it doesn't even send a valid HTTP request, we just want to check that the main app is accepting connections
|
||||
-- The code for resolving the "*4", "!4", "*6", "!6", "*" special values is taken from
|
||||
-- https://hackage.haskell.org/package/streaming-commons-0.2.2.4/docs/src/Data.Streaming.Network.html#bindPortGenEx
|
||||
reachMainApp :: AppConfig -> IO [Either IOException ()]
|
||||
reachMainApp AppConfig{..} =
|
||||
case configServerUnixSocket of
|
||||
Just path -> do
|
||||
sock <- socket AF_UNIX Stream 0
|
||||
(:[]) <$> try (do
|
||||
connect sock $ SockAddrUnix path
|
||||
withSocketsDo $ bracket (pure sock) close sendEmpty)
|
||||
Nothing -> do
|
||||
let
|
||||
host | configServerHost `elem` ["*4", "!4", "*6", "!6", "*"] = Nothing
|
||||
| otherwise = Just configServerHost
|
||||
filterAddrs xs =
|
||||
case configServerHost of
|
||||
"*4" -> ipv4Addrs xs ++ ipv6Addrs xs
|
||||
"!4" -> ipv4Addrs xs
|
||||
"*6" -> ipv6Addrs xs ++ ipv4Addrs xs
|
||||
"!6" -> ipv6Addrs xs
|
||||
_ -> xs
|
||||
ipv4Addrs = filter ((/=) AF_INET6 . addrFamily)
|
||||
ipv6Addrs = filter ((==) AF_INET6 . addrFamily)
|
||||
|
||||
addrs <- getAddrInfo (Just $ defaultHints { addrSocketType = Stream }) (T.unpack <$> host) (Just . show $ configServerPort)
|
||||
tryAddr `traverse` filterAddrs addrs
|
||||
where
|
||||
sendEmpty sock = void $ send sock mempty
|
||||
tryAddr :: AddrInfo -> IO (Either IOException ())
|
||||
tryAddr addr = do
|
||||
sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
|
||||
try $ do
|
||||
connect sock $ addrAddress addr
|
||||
withSocketsDo $ bracket (pure sock) close sendEmpty
|
||||
@@ -33,6 +33,7 @@ import qualified Hasql.Transaction.Sessions as SQL
|
||||
import qualified Network.Wai as Wai
|
||||
import qualified Network.Wai.Handler.Warp as Warp
|
||||
|
||||
import qualified PostgREST.Admin as Admin
|
||||
import qualified PostgREST.ApiRequest as ApiRequest
|
||||
import qualified PostgREST.ApiRequest.Types as ApiRequestTypes
|
||||
import qualified PostgREST.AppState as AppState
|
||||
@@ -43,7 +44,6 @@ import qualified PostgREST.Logger as Logger
|
||||
import qualified PostgREST.Plan as Plan
|
||||
import qualified PostgREST.Query as Query
|
||||
import qualified PostgREST.Response as Response
|
||||
import qualified PostgREST.Workers as Workers
|
||||
|
||||
import PostgREST.ApiRequest (Action (..), ApiRequest (..),
|
||||
Mutation (..), Target (..))
|
||||
@@ -68,14 +68,14 @@ type SocketRunner = Warp.Settings -> Wai.Application -> FileMode -> FilePath ->
|
||||
run :: SignalHandlerInstaller -> Maybe SocketRunner -> AppState -> IO ()
|
||||
run installHandlers maybeRunWithSocket appState = do
|
||||
conf@AppConfig{..} <- AppState.getConfig appState
|
||||
Workers.connectionWorker appState -- Loads the initial SchemaCache
|
||||
AppState.connectionWorker appState -- Loads the initial SchemaCache
|
||||
installHandlers appState
|
||||
-- reload schema cache + config on NOTIFY
|
||||
Workers.runListener conf appState
|
||||
AppState.runListener conf appState
|
||||
|
||||
Workers.runAdmin conf appState $ serverSettings conf
|
||||
Admin.runAdmin conf appState $ serverSettings conf
|
||||
|
||||
let app = postgrest conf appState (Workers.connectionWorker appState)
|
||||
let app = postgrest conf appState (AppState.connectionWorker appState)
|
||||
|
||||
case configServerUnixSocket of
|
||||
Just socket ->
|
||||
|
||||
+276
-23
@@ -1,9 +1,10 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module PostgREST.AppState
|
||||
( AppState
|
||||
, destroy
|
||||
, flushPool
|
||||
, getConfig
|
||||
, getSchemaCache
|
||||
, getIsListenerOn
|
||||
@@ -11,40 +12,50 @@ module PostgREST.AppState
|
||||
, getPgVersion
|
||||
, getRetryNextIn
|
||||
, getTime
|
||||
, getWorkerSem
|
||||
, init
|
||||
, initWithPool
|
||||
, logWithZTime
|
||||
, logPgrstError
|
||||
, putConfig
|
||||
, putSchemaCache
|
||||
, putIsListenerOn
|
||||
, putPgVersion
|
||||
, putRetryNextIn
|
||||
, signalListener
|
||||
, usePool
|
||||
, waitListener
|
||||
, debounceLogAcquisitionTimeout
|
||||
, loadSchemaCache
|
||||
, reReadConfig
|
||||
, connectionWorker
|
||||
, runListener
|
||||
) where
|
||||
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import qualified Data.Text.Encoding as T
|
||||
import qualified Hasql.Pool as SQL
|
||||
import qualified Hasql.Session as SQL
|
||||
import qualified PostgREST.Error as Error
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import qualified Data.Text.Encoding as T
|
||||
import Hasql.Connection (acquire)
|
||||
import qualified Hasql.Notifications as SQL
|
||||
import qualified Hasql.Pool as SQL
|
||||
import qualified Hasql.Session as SQL
|
||||
import qualified Hasql.Transaction.Sessions as SQL
|
||||
import qualified PostgREST.Error as Error
|
||||
|
||||
import Control.AutoUpdate (defaultUpdateSettings, mkAutoUpdate,
|
||||
updateAction)
|
||||
import Control.Debounce
|
||||
import Control.Retry (RetryStatus, capDelay, exponentialBackoff,
|
||||
retrying, rsPreviousDelay)
|
||||
import Data.IORef (IORef, atomicWriteIORef, newIORef,
|
||||
readIORef)
|
||||
import Data.Time (ZonedTime, defaultTimeLocale, formatTime,
|
||||
getZonedTime)
|
||||
import Data.Time.Clock (UTCTime, getCurrentTime)
|
||||
|
||||
import PostgREST.Config (AppConfig (..))
|
||||
import PostgREST.Config.PgVersion (PgVersion (..), minimumPgVersion)
|
||||
import PostgREST.SchemaCache (SchemaCache)
|
||||
import PostgREST.Config (AppConfig (..),
|
||||
readAppConfig)
|
||||
import PostgREST.Config.Database (queryDbSettings,
|
||||
queryPgVersion,
|
||||
queryRoleSettings)
|
||||
import PostgREST.Config.PgVersion (PgVersion (..),
|
||||
minimumPgVersion)
|
||||
import PostgREST.SchemaCache (SchemaCache,
|
||||
querySchemaCache)
|
||||
import PostgREST.SchemaCache.Identifiers (dumpQi)
|
||||
|
||||
import Protolude
|
||||
|
||||
@@ -56,8 +67,8 @@ data AppState = AppState
|
||||
, statePgVersion :: IORef PgVersion
|
||||
-- | No schema cache at the start. Will be filled in by the connectionWorker
|
||||
, stateSchemaCache :: IORef (Maybe SchemaCache)
|
||||
-- | Binary semaphore to make sure just one connectionWorker can run at a time
|
||||
, stateWorkerSem :: MVar ()
|
||||
-- | starts the connection worker with a debounce
|
||||
, debouncedConnectionWorker :: IO ()
|
||||
-- | Binary semaphore used to sync the listener(NOTIFY reload) with the connectionWorker.
|
||||
, stateListener :: MVar ()
|
||||
-- | State of the LISTEN channel, used for the admin server checks
|
||||
@@ -86,7 +97,7 @@ initWithPool pool conf = do
|
||||
appState <- AppState pool
|
||||
<$> newIORef minimumPgVersion -- assume we're in a supported version when starting, this will be corrected on a later step
|
||||
<*> newIORef Nothing
|
||||
<*> newEmptyMVar
|
||||
<*> pure (pure ())
|
||||
<*> newEmptyMVar
|
||||
<*> newIORef False
|
||||
<*> newIORef conf
|
||||
@@ -96,7 +107,8 @@ initWithPool pool conf = do
|
||||
<*> newIORef 0
|
||||
<*> pure (pure ())
|
||||
|
||||
deb <-
|
||||
|
||||
debLogTimeout <-
|
||||
let oneSecond = 1000000 in
|
||||
mkDebounce defaultDebounceSettings
|
||||
{ debounceAction = logPgrstError appState SQL.AcquisitionTimeoutUsageError
|
||||
@@ -104,7 +116,15 @@ initWithPool pool conf = do
|
||||
, debounceEdge = leadingEdge -- logs at the start and the end
|
||||
}
|
||||
|
||||
return appState { debounceLogAcquisitionTimeout = deb }
|
||||
debWorker <-
|
||||
let decisecond = 100000 in
|
||||
mkDebounce defaultDebounceSettings
|
||||
{ debounceAction = internalConnectionWorker appState
|
||||
, debounceFreq = decisecond
|
||||
, debounceEdge = leadingEdge -- runs the worker at the start and the end
|
||||
}
|
||||
|
||||
return appState { debounceLogAcquisitionTimeout = debLogTimeout, debouncedConnectionWorker = debWorker }
|
||||
|
||||
destroy :: AppState -> IO ()
|
||||
destroy = destroyPool
|
||||
@@ -143,8 +163,8 @@ getSchemaCache = readIORef . stateSchemaCache
|
||||
putSchemaCache :: AppState -> Maybe SchemaCache -> IO ()
|
||||
putSchemaCache appState = atomicWriteIORef (stateSchemaCache appState)
|
||||
|
||||
getWorkerSem :: AppState -> MVar ()
|
||||
getWorkerSem = stateWorkerSem
|
||||
connectionWorker :: AppState -> IO ()
|
||||
connectionWorker = debouncedConnectionWorker
|
||||
|
||||
getRetryNextIn :: AppState -> IO Int
|
||||
getRetryNextIn = readIORef . stateRetryNextIn
|
||||
@@ -189,3 +209,236 @@ getIsListenerOn = readIORef . stateIsListenerOn
|
||||
|
||||
putIsListenerOn :: AppState -> Bool -> IO ()
|
||||
putIsListenerOn = atomicWriteIORef . stateIsListenerOn
|
||||
|
||||
-- | Schema cache status
|
||||
data SCacheStatus
|
||||
= SCLoaded
|
||||
| SCOnRetry
|
||||
| SCFatalFail
|
||||
|
||||
-- | Load the SchemaCache by using a connection from the pool.
|
||||
loadSchemaCache :: AppState -> IO SCacheStatus
|
||||
loadSchemaCache appState = do
|
||||
conf@AppConfig{..} <- getConfig appState
|
||||
result <-
|
||||
let transaction = if configDbPreparedStatements then SQL.transaction else SQL.unpreparedTransaction in
|
||||
usePool appState . transaction SQL.ReadCommitted SQL.Read $
|
||||
querySchemaCache conf
|
||||
case result of
|
||||
Left e -> do
|
||||
case Error.checkIsFatal e of
|
||||
Just hint -> do
|
||||
logWithZTime appState "A fatal error ocurred when loading the schema cache"
|
||||
logPgrstError appState e
|
||||
logWithZTime appState hint
|
||||
return SCFatalFail
|
||||
Nothing -> do
|
||||
putSchemaCache appState Nothing
|
||||
logWithZTime appState "An error ocurred when loading the schema cache"
|
||||
logPgrstError appState e
|
||||
return SCOnRetry
|
||||
|
||||
Right sCache -> do
|
||||
putSchemaCache appState (Just sCache)
|
||||
logWithZTime appState "Schema cache loaded"
|
||||
return SCLoaded
|
||||
|
||||
-- | Current database connection status data ConnectionStatus
|
||||
data ConnectionStatus
|
||||
= NotConnected
|
||||
| Connected PgVersion
|
||||
| FatalConnectionError Text
|
||||
deriving (Eq)
|
||||
|
||||
-- | The purpose of this worker is to obtain a healthy connection to pg and an
|
||||
-- up-to-date schema cache(SchemaCache). This method is meant to be called
|
||||
-- multiple times by the same thread, but does nothing if the previous
|
||||
-- invocation has not terminated. In all cases this method does not halt the
|
||||
-- calling thread, the work is performed in a separate thread.
|
||||
--
|
||||
-- Background thread that does the following :
|
||||
-- 1. Tries to connect to pg server and will keep trying until success.
|
||||
-- 2. Checks if the pg version is supported and if it's not it kills the main
|
||||
-- program.
|
||||
-- 3. Obtains the sCache. If this fails, it goes back to 1.
|
||||
internalConnectionWorker :: AppState -> IO ()
|
||||
internalConnectionWorker appState = work
|
||||
where
|
||||
work = do
|
||||
AppConfig{..} <- getConfig appState
|
||||
logWithZTime appState "Attempting to connect to the database..."
|
||||
connected <- establishConnection appState
|
||||
case connected of
|
||||
FatalConnectionError reason ->
|
||||
-- Fatal error when connecting
|
||||
logWithZTime appState reason >> killThread (getMainThreadId appState)
|
||||
NotConnected ->
|
||||
-- Unreachable because establishConnection will keep trying to connect
|
||||
return ()
|
||||
Connected actualPgVersion -> do
|
||||
-- Procede with initialization
|
||||
putPgVersion appState actualPgVersion
|
||||
when configDbChannelEnabled $
|
||||
signalListener appState
|
||||
logWithZTime appState "Connection successful"
|
||||
-- this could be fail because the connection drops, but the loadSchemaCache will pick the error and retry again
|
||||
-- We cannot retry after it fails immediately, because db-pre-config could have user errors. We just log the error and continue.
|
||||
when configDbConfig $ reReadConfig False appState
|
||||
scStatus <- loadSchemaCache appState
|
||||
case scStatus of
|
||||
SCLoaded ->
|
||||
-- do nothing and proceed if the load was successful
|
||||
return ()
|
||||
SCOnRetry ->
|
||||
-- retry reloading the schema cache
|
||||
work
|
||||
SCFatalFail ->
|
||||
-- die if our schema cache query has an error
|
||||
killThread $ getMainThreadId appState
|
||||
|
||||
-- | Repeatedly flush the pool, and check if a connection from the
|
||||
-- pool allows access to the PostgreSQL database.
|
||||
--
|
||||
-- Releasing the pool is key for rapid recovery. Otherwise, the pool
|
||||
-- timeout would have to be reached for new healthy connections to be acquired.
|
||||
-- Which might not happen if the server is busy with requests. No idle
|
||||
-- connection, no pool timeout.
|
||||
--
|
||||
-- The connection tries are capped, but if the connection times out no error is
|
||||
-- thrown, just 'False' is returned.
|
||||
establishConnection :: AppState -> IO ConnectionStatus
|
||||
establishConnection appState =
|
||||
retrying retrySettings shouldRetry $
|
||||
const $ flushPool appState >> getConnectionStatus
|
||||
where
|
||||
retrySettings = capDelay delayMicroseconds $ exponentialBackoff backoffMicroseconds
|
||||
delayMicroseconds = 32000000 -- 32 seconds
|
||||
backoffMicroseconds = 1000000 -- 1 second
|
||||
|
||||
getConnectionStatus :: IO ConnectionStatus
|
||||
getConnectionStatus = do
|
||||
pgVersion <- usePool appState $ queryPgVersion False -- No need to prepare the query here, as the connection might not be established
|
||||
case pgVersion of
|
||||
Left e -> do
|
||||
logPgrstError appState e
|
||||
case Error.checkIsFatal e of
|
||||
Just reason ->
|
||||
return $ FatalConnectionError reason
|
||||
Nothing ->
|
||||
return NotConnected
|
||||
Right version ->
|
||||
if version < minimumPgVersion then
|
||||
return . FatalConnectionError $
|
||||
"Cannot run in this PostgreSQL version, PostgREST needs at least "
|
||||
<> pgvName minimumPgVersion
|
||||
else
|
||||
return . Connected $ version
|
||||
|
||||
shouldRetry :: RetryStatus -> ConnectionStatus -> IO Bool
|
||||
shouldRetry rs isConnSucc = do
|
||||
let
|
||||
delay = fromMaybe 0 (rsPreviousDelay rs) `div` backoffMicroseconds
|
||||
itShould = NotConnected == isConnSucc
|
||||
when itShould . logWithZTime appState $
|
||||
"Attempting to reconnect to the database in "
|
||||
<> (show delay::Text)
|
||||
<> " seconds..."
|
||||
when itShould $ putRetryNextIn appState delay
|
||||
return itShould
|
||||
|
||||
-- | Re-reads the config plus config options from the db
|
||||
reReadConfig :: Bool -> AppState -> IO ()
|
||||
reReadConfig startingUp appState = do
|
||||
AppConfig{..} <- getConfig appState
|
||||
dbSettings <-
|
||||
if configDbConfig then do
|
||||
qDbSettings <- usePool appState $ queryDbSettings (dumpQi <$> configDbPreConfig) configDbPreparedStatements
|
||||
case qDbSettings of
|
||||
Left e -> do
|
||||
logWithZTime appState
|
||||
"An error ocurred when trying to query database settings for the config parameters"
|
||||
case Error.checkIsFatal e of
|
||||
Just hint -> do
|
||||
logPgrstError appState e
|
||||
logWithZTime appState hint
|
||||
killThread (getMainThreadId appState)
|
||||
Nothing -> do
|
||||
logPgrstError appState e
|
||||
pure mempty
|
||||
Right x -> pure x
|
||||
else
|
||||
pure mempty
|
||||
roleSettings <-
|
||||
if configDbConfig then do
|
||||
rSettings <- usePool appState $ queryRoleSettings configDbPreparedStatements
|
||||
case rSettings of
|
||||
Left e -> do
|
||||
logWithZTime appState "An error ocurred when trying to query the role settings"
|
||||
logPgrstError appState e
|
||||
pure mempty
|
||||
Right x -> pure x
|
||||
else
|
||||
pure mempty
|
||||
readAppConfig dbSettings configFilePath (Just configDbUri) roleSettings >>= \case
|
||||
Left err ->
|
||||
if startingUp then
|
||||
panic err -- die on invalid config if the program is starting up
|
||||
else
|
||||
logWithZTime appState $ "Failed reloading config: " <> err
|
||||
Right newConf -> do
|
||||
putConfig appState newConf
|
||||
if startingUp then
|
||||
pass
|
||||
else
|
||||
logWithZTime appState "Config reloaded"
|
||||
|
||||
|
||||
runListener :: AppConfig -> AppState -> IO ()
|
||||
runListener AppConfig{configDbChannelEnabled} appState =
|
||||
when configDbChannelEnabled $ listener appState
|
||||
|
||||
-- | Starts a dedicated pg connection to LISTEN for notifications. When a
|
||||
-- NOTIFY <db-channel> - with an empty payload - is done, it refills the schema
|
||||
-- cache. It uses the connectionWorker in case the LISTEN connection dies.
|
||||
listener :: AppState -> IO ()
|
||||
listener appState = do
|
||||
AppConfig{..} <- getConfig appState
|
||||
let dbChannel = toS configDbChannel
|
||||
|
||||
-- The listener has to wait for a signal from the connectionWorker.
|
||||
-- This is because when the connection to the db is lost, the listener also
|
||||
-- tries to recover the connection, but not with the same pace as the connectionWorker.
|
||||
-- Not waiting makes stderr quickly fill with connection retries messages from the listener.
|
||||
waitListener appState
|
||||
|
||||
-- forkFinally allows to detect if the thread dies
|
||||
void . flip forkFinally (handleFinally dbChannel) $ do
|
||||
dbOrError <- acquire $ toUtf8 configDbUri
|
||||
case dbOrError of
|
||||
Right db -> do
|
||||
logWithZTime appState $ "Listening for notifications on the " <> dbChannel <> " channel"
|
||||
putIsListenerOn appState True
|
||||
SQL.listen db $ SQL.toPgIdentifier dbChannel
|
||||
SQL.waitForNotifications handleNotification db
|
||||
_ ->
|
||||
die $ "Could not listen for notifications on the " <> dbChannel <> " channel"
|
||||
where
|
||||
handleFinally dbChannel _ = do
|
||||
-- if the thread dies, we try to recover
|
||||
logWithZTime appState $ "Retrying listening for notifications on the " <> dbChannel <> " channel.."
|
||||
putIsListenerOn appState False
|
||||
-- assume the pool connection was also lost, call the connection worker
|
||||
connectionWorker appState
|
||||
-- retry the listener
|
||||
listener appState
|
||||
|
||||
handleNotification _ msg
|
||||
| BS.null msg = cacheReloader
|
||||
| msg == "reload schema" = cacheReloader
|
||||
| msg == "reload config" = reReadConfig False appState
|
||||
| otherwise = pure () -- Do nothing if anything else than an empty message is sent
|
||||
|
||||
cacheReloader =
|
||||
-- reloads the schema cache + restarts pool connections
|
||||
-- it's necessary to restart the pg connections because they cache the pg catalog(see #2620)
|
||||
connectionWorker appState
|
||||
|
||||
@@ -21,7 +21,6 @@ import PostgREST.AppState (AppState)
|
||||
import PostgREST.Config (AppConfig (..))
|
||||
import PostgREST.SchemaCache (querySchemaCache)
|
||||
import PostgREST.Version (prettyVersion)
|
||||
import PostgREST.Workers (reReadConfig)
|
||||
|
||||
import qualified PostgREST.App as App
|
||||
import qualified PostgREST.AppState as AppState
|
||||
@@ -43,7 +42,7 @@ main installSignalHandlers runAppWithSocket CLI{cliCommand, cliPath} = do
|
||||
AppState.destroy
|
||||
(\appState -> case cliCommand of
|
||||
CmdDumpConfig -> do
|
||||
when configDbConfig $ reReadConfig True appState
|
||||
when configDbConfig $ AppState.reReadConfig True appState
|
||||
putStr . Config.toText =<< AppState.getConfig appState
|
||||
CmdDumpSchema -> putStrLn =<< dumpSchema appState
|
||||
CmdRun -> App.run installSignalHandlers runAppWithSocket appState)
|
||||
@@ -51,15 +50,12 @@ main installSignalHandlers runAppWithSocket CLI{cliCommand, cliPath} = do
|
||||
-- | Dump SchemaCache schema to JSON
|
||||
dumpSchema :: AppState -> IO LBS.ByteString
|
||||
dumpSchema appState = do
|
||||
AppConfig{..} <- AppState.getConfig appState
|
||||
conf@AppConfig{..} <- AppState.getConfig appState
|
||||
result <-
|
||||
let transaction = if configDbPreparedStatements then SQL.transaction else SQL.unpreparedTransaction in
|
||||
AppState.usePool appState $
|
||||
transaction SQL.ReadCommitted SQL.Read $
|
||||
querySchemaCache
|
||||
(toList configDbSchemas)
|
||||
configDbExtraSearchPath
|
||||
configDbPreparedStatements
|
||||
querySchemaCache conf
|
||||
case result of
|
||||
Left e -> do
|
||||
hPutStrLn stderr $ "An error ocurred when loading the schema cache:\n" <> show e
|
||||
|
||||
@@ -103,6 +103,7 @@ data AppConfig = AppConfig
|
||||
, configServerUnixSocketMode :: FileMode
|
||||
, configAdminServerPort :: Maybe Int
|
||||
, configRoleSettings :: RoleSettings
|
||||
, configInternalSCSleep :: Maybe Int32
|
||||
}
|
||||
|
||||
data LogLevel = LogCrit | LogError | LogWarn | LogInfo
|
||||
@@ -267,6 +268,7 @@ parser optPath env dbSettings roleSettings =
|
||||
<*> parseSocketFileMode "server-unix-socket-mode"
|
||||
<*> optInt "admin-server-port"
|
||||
<*> pure roleSettings
|
||||
<*> optInt "internal-schema-cache-sleep"
|
||||
where
|
||||
parseAppSettings :: C.Key -> C.Parser C.Config [(Text, Text)]
|
||||
parseAppSettings key = addFromEnv . fmap (fmap coerceText) <$> C.subassocs key C.value
|
||||
|
||||
@@ -26,6 +26,8 @@ module PostgREST.SchemaCache
|
||||
, schemaDescription
|
||||
) where
|
||||
|
||||
import Control.Monad.Extra (whenJust)
|
||||
|
||||
import qualified Data.Aeson as JSON
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import qualified Data.HashMap.Strict.InsOrd as HMI
|
||||
@@ -38,6 +40,7 @@ import qualified Hasql.Transaction as SQL
|
||||
import Contravariant.Extras (contrazip2)
|
||||
import Text.InterpolatedString.Perl6 (q)
|
||||
|
||||
import PostgREST.Config (AppConfig (..))
|
||||
import PostgREST.Config.Database (pgVersionStatement)
|
||||
import PostgREST.Config.PgVersion (PgVersion, pgVersion100,
|
||||
pgVersion110, pgVersion120)
|
||||
@@ -103,15 +106,18 @@ data KeyDep
|
||||
-- | A SQL query that can be executed independently
|
||||
type SqlQuery = ByteString
|
||||
|
||||
querySchemaCache :: [Schema] -> [Schema] -> Bool -> SQL.Transaction SchemaCache
|
||||
querySchemaCache schemas extraSearchPath prepared = do
|
||||
querySchemaCache :: AppConfig -> SQL.Transaction SchemaCache
|
||||
querySchemaCache AppConfig{..} = do
|
||||
SQL.sql "set local schema ''" -- This voids the search path. The following queries need this for getting the fully qualified name(schema.name) of every db object
|
||||
pgVer <- SQL.statement mempty $ pgVersionStatement prepared
|
||||
tabs <- SQL.statement schemas $ allTables pgVer prepared
|
||||
keyDeps <- SQL.statement (schemas, extraSearchPath) $ allViewsKeyDependencies prepared
|
||||
keyDeps <- SQL.statement (schemas, configDbExtraSearchPath) $ allViewsKeyDependencies prepared
|
||||
m2oRels <- SQL.statement mempty $ allM2OandO2ORels pgVer prepared
|
||||
funcs <- SQL.statement schemas $ allFunctions pgVer prepared
|
||||
cRels <- SQL.statement mempty $ allComputedRels prepared
|
||||
_ <-
|
||||
let sleepCall = SQL.Statement "select pg_sleep($1)" (param HE.int4) HD.noResult prepared in
|
||||
whenJust configInternalSCSleep (`SQL.statement` sleepCall) -- only used for testing
|
||||
|
||||
let tabsWViewsPks = addViewPrimaryKeys tabs keyDeps
|
||||
rels = addInverseRels $ addM2MRels tabsWViewsPks $ addViewM2OAndO2ORels keyDeps m2oRels
|
||||
@@ -121,6 +127,9 @@ querySchemaCache schemas extraSearchPath prepared = do
|
||||
, dbRelationships = getOverrideRelationshipsMap rels cRels
|
||||
, dbRoutines = funcs
|
||||
}
|
||||
where
|
||||
schemas = toList configDbSchemas
|
||||
prepared = configDbPreparedStatements
|
||||
|
||||
-- | overrides detected relationships with the computed relationships and gets the RelationshipsMap
|
||||
getOverrideRelationshipsMap :: [Relationship] -> [Relationship] -> RelationshipsMap
|
||||
|
||||
@@ -14,7 +14,6 @@ import System.Posix.Files (setFileMode)
|
||||
import System.Posix.Types (FileMode)
|
||||
|
||||
import qualified PostgREST.AppState as AppState
|
||||
import qualified PostgREST.Workers as Workers
|
||||
|
||||
import Protolude
|
||||
|
||||
@@ -49,10 +48,10 @@ installSignalHandlers appState = do
|
||||
|
||||
-- The SIGUSR1 signal updates the internal 'SchemaCache' by running
|
||||
-- 'connectionWorker' exactly as before.
|
||||
install Signals.sigUSR1 $ Workers.connectionWorker appState
|
||||
install Signals.sigUSR1 $ AppState.connectionWorker appState
|
||||
|
||||
-- Re-read the config on SIGUSR2
|
||||
install Signals.sigUSR2 $ Workers.reReadConfig False appState
|
||||
install Signals.sigUSR2 $ AppState.reReadConfig False appState
|
||||
where
|
||||
install signal handler =
|
||||
void $ Signals.installHandler signal (Signals.Catch handler) Nothing
|
||||
|
||||
@@ -1,347 +0,0 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module PostgREST.Workers
|
||||
( connectionWorker
|
||||
, reReadConfig
|
||||
, runListener
|
||||
, runAdmin
|
||||
) where
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.Text as T
|
||||
import qualified Hasql.Notifications as SQL
|
||||
import qualified Hasql.Session as SQL
|
||||
import qualified Hasql.Transaction.Sessions as SQL
|
||||
import qualified Network.HTTP.Types.Status as HTTP
|
||||
import qualified Network.Wai as Wai
|
||||
import qualified Network.Wai.Handler.Warp as Warp
|
||||
|
||||
import Control.Retry (RetryStatus, capDelay, exponentialBackoff,
|
||||
retrying, rsPreviousDelay)
|
||||
import Hasql.Connection (acquire)
|
||||
|
||||
import Network.Socket
|
||||
import Network.Socket.ByteString
|
||||
|
||||
import PostgREST.AppState (AppState)
|
||||
import PostgREST.Config (AppConfig (..),
|
||||
readAppConfig)
|
||||
import PostgREST.Config.Database (queryDbSettings,
|
||||
queryPgVersion,
|
||||
queryRoleSettings)
|
||||
import PostgREST.Config.PgVersion (PgVersion (..),
|
||||
minimumPgVersion)
|
||||
import PostgREST.Error (checkIsFatal)
|
||||
import PostgREST.SchemaCache (querySchemaCache)
|
||||
import PostgREST.SchemaCache.Identifiers (dumpQi)
|
||||
|
||||
import qualified PostgREST.AppState as AppState
|
||||
|
||||
import Protolude
|
||||
|
||||
|
||||
-- | Current database connection status data ConnectionStatus
|
||||
data ConnectionStatus
|
||||
= NotConnected
|
||||
| Connected PgVersion
|
||||
| FatalConnectionError Text
|
||||
deriving (Eq)
|
||||
|
||||
-- | Schema cache status
|
||||
data SCacheStatus
|
||||
= SCLoaded
|
||||
| SCOnRetry
|
||||
| SCFatalFail
|
||||
|
||||
-- | The purpose of this worker is to obtain a healthy connection to pg and an
|
||||
-- up-to-date schema cache(SchemaCache). This method is meant to be called
|
||||
-- multiple times by the same thread, but does nothing if the previous
|
||||
-- invocation has not terminated. In all cases this method does not halt the
|
||||
-- calling thread, the work is performed in a separate thread.
|
||||
--
|
||||
-- Background thread that does the following :
|
||||
-- 1. Tries to connect to pg server and will keep trying until success.
|
||||
-- 2. Checks if the pg version is supported and if it's not it kills the main
|
||||
-- program.
|
||||
-- 3. Obtains the sCache. If this fails, it goes back to 1.
|
||||
connectionWorker :: AppState -> IO ()
|
||||
connectionWorker appState = do
|
||||
runExclusively (AppState.getWorkerSem appState) work
|
||||
-- Prevents multiple workers to be running at the same time. Could happen on
|
||||
-- too many SIGUSR1s.
|
||||
where
|
||||
runExclusively mvar action = mask_ $ do
|
||||
success <- tryPutMVar mvar ()
|
||||
when success $ do
|
||||
void $ forkIO $ action `finally` takeMVar mvar
|
||||
work = do
|
||||
AppConfig{..} <- AppState.getConfig appState
|
||||
AppState.logWithZTime appState "Attempting to connect to the database..."
|
||||
connected <- establishConnection appState
|
||||
case connected of
|
||||
FatalConnectionError reason ->
|
||||
-- Fatal error when connecting
|
||||
AppState.logWithZTime appState reason >> killThread (AppState.getMainThreadId appState)
|
||||
NotConnected ->
|
||||
-- Unreachable because establishConnection will keep trying to connect
|
||||
return ()
|
||||
Connected actualPgVersion -> do
|
||||
-- Procede with initialization
|
||||
AppState.putPgVersion appState actualPgVersion
|
||||
when configDbChannelEnabled $
|
||||
AppState.signalListener appState
|
||||
AppState.logWithZTime appState "Connection successful"
|
||||
-- this could be fail because the connection drops, but the loadSchemaCache will pick the error and retry again
|
||||
-- We cannot retry after it fails immediately, because db-pre-config could have user errors. We just log the error and continue.
|
||||
when configDbConfig $ reReadConfig False appState
|
||||
scStatus <- loadSchemaCache appState
|
||||
case scStatus of
|
||||
SCLoaded ->
|
||||
-- do nothing and proceed if the load was successful
|
||||
return ()
|
||||
SCOnRetry ->
|
||||
-- retry reloading the schema cache
|
||||
work
|
||||
SCFatalFail ->
|
||||
-- die if our schema cache query has an error
|
||||
killThread $ AppState.getMainThreadId appState
|
||||
|
||||
-- | Repeatedly flush the pool, and check if a connection from the
|
||||
-- pool allows access to the PostgreSQL database.
|
||||
--
|
||||
-- Releasing the pool is key for rapid recovery. Otherwise, the pool
|
||||
-- timeout would have to be reached for new healthy connections to be acquired.
|
||||
-- Which might not happen if the server is busy with requests. No idle
|
||||
-- connection, no pool timeout.
|
||||
--
|
||||
-- The connection tries are capped, but if the connection times out no error is
|
||||
-- thrown, just 'False' is returned.
|
||||
establishConnection :: AppState -> IO ConnectionStatus
|
||||
establishConnection appState =
|
||||
retrying retrySettings shouldRetry $
|
||||
const $ AppState.flushPool appState >> getConnectionStatus
|
||||
where
|
||||
retrySettings = capDelay delayMicroseconds $ exponentialBackoff backoffMicroseconds
|
||||
delayMicroseconds = 32000000 -- 32 seconds
|
||||
backoffMicroseconds = 1000000 -- 1 second
|
||||
|
||||
getConnectionStatus :: IO ConnectionStatus
|
||||
getConnectionStatus = do
|
||||
pgVersion <- AppState.usePool appState $ queryPgVersion False -- No need to prepare the query here, as the connection might not be established
|
||||
case pgVersion of
|
||||
Left e -> do
|
||||
AppState.logPgrstError appState e
|
||||
case checkIsFatal e of
|
||||
Just reason ->
|
||||
return $ FatalConnectionError reason
|
||||
Nothing ->
|
||||
return NotConnected
|
||||
Right version ->
|
||||
if version < minimumPgVersion then
|
||||
return . FatalConnectionError $
|
||||
"Cannot run in this PostgreSQL version, PostgREST needs at least "
|
||||
<> pgvName minimumPgVersion
|
||||
else
|
||||
return . Connected $ version
|
||||
|
||||
shouldRetry :: RetryStatus -> ConnectionStatus -> IO Bool
|
||||
shouldRetry rs isConnSucc = do
|
||||
let
|
||||
delay = fromMaybe 0 (rsPreviousDelay rs) `div` backoffMicroseconds
|
||||
itShould = NotConnected == isConnSucc
|
||||
when itShould . AppState.logWithZTime appState $
|
||||
"Attempting to reconnect to the database in "
|
||||
<> (show delay::Text)
|
||||
<> " seconds..."
|
||||
when itShould $ AppState.putRetryNextIn appState delay
|
||||
return itShould
|
||||
|
||||
-- | Load the SchemaCache by using a connection from the pool.
|
||||
loadSchemaCache :: AppState -> IO SCacheStatus
|
||||
loadSchemaCache appState = do
|
||||
AppConfig{..} <- AppState.getConfig appState
|
||||
result <-
|
||||
let transaction = if configDbPreparedStatements then SQL.transaction else SQL.unpreparedTransaction in
|
||||
AppState.usePool appState . transaction SQL.ReadCommitted SQL.Read $
|
||||
querySchemaCache (toList configDbSchemas) configDbExtraSearchPath configDbPreparedStatements
|
||||
case result of
|
||||
Left e -> do
|
||||
case checkIsFatal e of
|
||||
Just hint -> do
|
||||
AppState.logWithZTime appState "A fatal error ocurred when loading the schema cache"
|
||||
AppState.logPgrstError appState e
|
||||
AppState.logWithZTime appState hint
|
||||
return SCFatalFail
|
||||
Nothing -> do
|
||||
AppState.putSchemaCache appState Nothing
|
||||
AppState.logWithZTime appState "An error ocurred when loading the schema cache"
|
||||
AppState.logPgrstError appState e
|
||||
return SCOnRetry
|
||||
|
||||
Right sCache -> do
|
||||
AppState.putSchemaCache appState (Just sCache)
|
||||
AppState.logWithZTime appState "Schema cache loaded"
|
||||
return SCLoaded
|
||||
|
||||
runListener :: AppConfig -> AppState -> IO ()
|
||||
runListener AppConfig{configDbChannelEnabled} appState =
|
||||
when configDbChannelEnabled $ listener appState
|
||||
|
||||
-- | Starts a dedicated pg connection to LISTEN for notifications. When a
|
||||
-- NOTIFY <db-channel> - with an empty payload - is done, it refills the schema
|
||||
-- cache. It uses the connectionWorker in case the LISTEN connection dies.
|
||||
listener :: AppState -> IO ()
|
||||
listener appState = do
|
||||
AppConfig{..} <- AppState.getConfig appState
|
||||
let dbChannel = toS configDbChannel
|
||||
|
||||
-- The listener has to wait for a signal from the connectionWorker.
|
||||
-- This is because when the connection to the db is lost, the listener also
|
||||
-- tries to recover the connection, but not with the same pace as the connectionWorker.
|
||||
-- Not waiting makes stderr quickly fill with connection retries messages from the listener.
|
||||
AppState.waitListener appState
|
||||
|
||||
-- forkFinally allows to detect if the thread dies
|
||||
void . flip forkFinally (handleFinally dbChannel) $ do
|
||||
dbOrError <- acquire $ toUtf8 configDbUri
|
||||
case dbOrError of
|
||||
Right db -> do
|
||||
AppState.logWithZTime appState $ "Listening for notifications on the " <> dbChannel <> " channel"
|
||||
AppState.putIsListenerOn appState True
|
||||
SQL.listen db $ SQL.toPgIdentifier dbChannel
|
||||
SQL.waitForNotifications handleNotification db
|
||||
_ ->
|
||||
die $ "Could not listen for notifications on the " <> dbChannel <> " channel"
|
||||
where
|
||||
handleFinally dbChannel _ = do
|
||||
-- if the thread dies, we try to recover
|
||||
AppState.logWithZTime appState $ "Retrying listening for notifications on the " <> dbChannel <> " channel.."
|
||||
AppState.putIsListenerOn appState False
|
||||
-- assume the pool connection was also lost, call the connection worker
|
||||
connectionWorker appState
|
||||
-- retry the listener
|
||||
listener appState
|
||||
|
||||
handleNotification _ msg
|
||||
| BS.null msg = cacheReloader
|
||||
| msg == "reload schema" = cacheReloader
|
||||
| msg == "reload config" = reReadConfig False appState
|
||||
| otherwise = pure () -- Do nothing if anything else than an empty message is sent
|
||||
|
||||
cacheReloader =
|
||||
-- reloads the schema cache + restarts pool connections
|
||||
-- it's necessary to restart the pg connections because they cache the pg catalog(see #2620)
|
||||
connectionWorker appState
|
||||
|
||||
-- | Re-reads the config plus config options from the db
|
||||
reReadConfig :: Bool -> AppState -> IO ()
|
||||
reReadConfig startingUp appState = do
|
||||
AppConfig{..} <- AppState.getConfig appState
|
||||
dbSettings <-
|
||||
if configDbConfig then do
|
||||
qDbSettings <- AppState.usePool appState $ queryDbSettings (dumpQi <$> configDbPreConfig) configDbPreparedStatements
|
||||
case qDbSettings of
|
||||
Left e -> do
|
||||
AppState.logWithZTime appState
|
||||
"An error ocurred when trying to query database settings for the config parameters"
|
||||
case checkIsFatal e of
|
||||
Just hint -> do
|
||||
AppState.logPgrstError appState e
|
||||
AppState.logWithZTime appState hint
|
||||
killThread (AppState.getMainThreadId appState)
|
||||
Nothing -> do
|
||||
AppState.logPgrstError appState e
|
||||
pure mempty
|
||||
Right x -> pure x
|
||||
else
|
||||
pure mempty
|
||||
roleSettings <-
|
||||
if configDbConfig then do
|
||||
rSettings <- AppState.usePool appState $ queryRoleSettings configDbPreparedStatements
|
||||
case rSettings of
|
||||
Left e -> do
|
||||
AppState.logWithZTime appState "An error ocurred when trying to query the role settings"
|
||||
AppState.logPgrstError appState e
|
||||
pure mempty
|
||||
Right x -> pure x
|
||||
else
|
||||
pure mempty
|
||||
readAppConfig dbSettings configFilePath (Just configDbUri) roleSettings >>= \case
|
||||
Left err ->
|
||||
if startingUp then
|
||||
panic err -- die on invalid config if the program is starting up
|
||||
else
|
||||
AppState.logWithZTime appState $ "Failed reloading config: " <> err
|
||||
Right newConf -> do
|
||||
AppState.putConfig appState newConf
|
||||
if startingUp then
|
||||
pass
|
||||
else
|
||||
AppState.logWithZTime appState "Config reloaded"
|
||||
|
||||
runAdmin :: AppConfig -> AppState -> Warp.Settings -> IO ()
|
||||
runAdmin conf@AppConfig{configAdminServerPort} appState settings =
|
||||
whenJust configAdminServerPort $ \adminPort -> do
|
||||
AppState.logWithZTime appState $ "Admin server listening on port " <> show adminPort
|
||||
void . forkIO $ Warp.runSettings (settings & Warp.setPort adminPort) adminApp
|
||||
where
|
||||
whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m ()
|
||||
whenJust mg f = maybe (pure ()) f mg
|
||||
adminApp = admin appState conf
|
||||
|
||||
-- | PostgREST admin application
|
||||
admin :: AppState.AppState -> AppConfig -> Wai.Application
|
||||
admin appState appConfig req respond = do
|
||||
isMainAppReachable <- any isRight <$> reachMainApp appConfig
|
||||
isSchemaCacheLoaded <- isJust <$> AppState.getSchemaCache appState
|
||||
isConnectionUp <-
|
||||
if configDbChannelEnabled appConfig
|
||||
then AppState.getIsListenerOn appState
|
||||
else isRight <$> AppState.usePool appState (SQL.sql "SELECT 1")
|
||||
|
||||
case Wai.pathInfo req of
|
||||
["ready"] ->
|
||||
respond $ Wai.responseLBS (if isMainAppReachable && isConnectionUp && isSchemaCacheLoaded then HTTP.status200 else HTTP.status503) [] mempty
|
||||
["live"] ->
|
||||
respond $ Wai.responseLBS (if isMainAppReachable then HTTP.status200 else HTTP.status503) [] mempty
|
||||
_ ->
|
||||
respond $ Wai.responseLBS HTTP.status404 [] mempty
|
||||
|
||||
-- Try to connect to the main app socket
|
||||
-- Note that it doesn't even send a valid HTTP request, we just want to check that the main app is accepting connections
|
||||
-- The code for resolving the "*4", "!4", "*6", "!6", "*" special values is taken from
|
||||
-- https://hackage.haskell.org/package/streaming-commons-0.2.2.4/docs/src/Data.Streaming.Network.html#bindPortGenEx
|
||||
reachMainApp :: AppConfig -> IO [Either IOException ()]
|
||||
reachMainApp AppConfig{..} =
|
||||
case configServerUnixSocket of
|
||||
Just path -> do
|
||||
sock <- socket AF_UNIX Stream 0
|
||||
(:[]) <$> try (do
|
||||
connect sock $ SockAddrUnix path
|
||||
withSocketsDo $ bracket (pure sock) close sendEmpty)
|
||||
Nothing -> do
|
||||
let
|
||||
host | configServerHost `elem` ["*4", "!4", "*6", "!6", "*"] = Nothing
|
||||
| otherwise = Just configServerHost
|
||||
filterAddrs xs =
|
||||
case configServerHost of
|
||||
"*4" -> ipv4Addrs xs ++ ipv6Addrs xs
|
||||
"!4" -> ipv4Addrs xs
|
||||
"*6" -> ipv6Addrs xs ++ ipv4Addrs xs
|
||||
"!6" -> ipv6Addrs xs
|
||||
_ -> xs
|
||||
ipv4Addrs = filter ((/=) AF_INET6 . addrFamily)
|
||||
ipv6Addrs = filter ((==) AF_INET6 . addrFamily)
|
||||
|
||||
addrs <- getAddrInfo (Just $ defaultHints { addrSocketType = Stream }) (T.unpack <$> host) (Just . show $ configServerPort)
|
||||
tryAddr `traverse` filterAddrs addrs
|
||||
where
|
||||
sendEmpty sock = void $ send sock mempty
|
||||
tryAddr :: AddrInfo -> IO (Either IOException ())
|
||||
tryAddr addr = do
|
||||
sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
|
||||
try $ do
|
||||
connect sock $ addrAddress addr
|
||||
withSocketsDo $ bracket (pure sock) close sendEmpty
|
||||
Reference in New Issue
Block a user