refactor: observation handler to AppConfig

With this:

- Is no longer necessary to pass observer as an argument
  to every function that needs observations.
- We can invoke the observer on every function that uses AppConfig.
  However it'd be better to just call the observer in the upper modules
  (like on App.hs).
This commit is contained in:
steve-chavez
2024-04-12 14:29:39 -05:00
committed by Steve Chavez
parent 460259548d
commit 2de32fc108
10 changed files with 97 additions and 93 deletions
+6 -6
View File
@@ -26,23 +26,23 @@ import qualified PostgREST.Config as Config
import Protolude import Protolude
runAdmin :: AppConfig -> AppState -> Warp.Settings -> (Observation -> IO ()) -> IO () runAdmin :: AppConfig -> AppState -> Warp.Settings -> IO ()
runAdmin conf@AppConfig{configAdminServerPort} appState settings observer = runAdmin conf@AppConfig{configAdminServerPort, configObserver=observer} appState settings =
whenJust (AppState.getSocketAdmin appState) $ \adminSocket -> do whenJust (AppState.getSocketAdmin appState) $ \adminSocket -> do
observer $ AdminStartObs configAdminServerPort observer $ AdminStartObs configAdminServerPort
void . forkIO $ Warp.runSettingsSocket settings adminSocket adminApp void . forkIO $ Warp.runSettingsSocket settings adminSocket adminApp
where where
adminApp = admin appState conf observer adminApp = admin appState conf
-- | PostgREST admin application -- | PostgREST admin application
admin :: AppState.AppState -> AppConfig -> (Observation -> IO ()) -> Wai.Application admin :: AppState.AppState -> AppConfig -> Wai.Application
admin appState appConfig observer req respond = do admin appState appConfig req respond = do
isMainAppReachable <- isRight <$> reachMainApp (AppState.getSocketREST appState) isMainAppReachable <- isRight <$> reachMainApp (AppState.getSocketREST appState)
isSchemaCacheLoaded <- AppState.getSchemaCacheLoaded appState isSchemaCacheLoaded <- AppState.getSchemaCacheLoaded appState
isConnectionUp <- isConnectionUp <-
if configDbChannelEnabled appConfig if configDbChannelEnabled appConfig
then AppState.getIsListenerOn appState then AppState.getIsListenerOn appState
else isRight <$> AppState.usePool appState appConfig (SQL.sql "SELECT 1") observer else isRight <$> AppState.usePool appState appConfig (SQL.sql "SELECT 1")
case Wai.pathInfo req of case Wai.pathInfo req of
["ready"] -> ["ready"] ->
+13 -13
View File
@@ -60,19 +60,20 @@ import System.TimeIt (timeItT)
type Handler = ExceptT Error type Handler = ExceptT Error
run :: AppState -> (Observation -> IO ()) -> IO () run :: AppState -> IO ()
run appState observer = do run appState = do
conf@AppConfig{configObserver=observer, ..} <- AppState.getConfig appState
observer $ AppServerStartObs prettyVersion observer $ AppServerStartObs prettyVersion
conf@AppConfig{..} <- AppState.getConfig appState
AppState.connectionWorker appState -- Loads the initial SchemaCache AppState.connectionWorker appState -- Loads the initial SchemaCache
Unix.installSignalHandlers (AppState.getMainThreadId appState) (AppState.connectionWorker appState) (AppState.reReadConfig False appState observer) Unix.installSignalHandlers (AppState.getMainThreadId appState) (AppState.connectionWorker appState) (AppState.reReadConfig False appState)
-- reload schema cache + config on NOTIFY -- reload schema cache + config on NOTIFY
AppState.runListener conf appState observer AppState.runListener conf appState
Admin.runAdmin conf appState (serverSettings conf) observer Admin.runAdmin conf appState (serverSettings conf)
let app = postgrest configLogLevel appState (AppState.connectionWorker appState) observer let app = postgrest configLogLevel appState (AppState.connectionWorker appState)
case configServerUnixSocket of case configServerUnixSocket of
Just path -> do Just path -> do
@@ -91,8 +92,8 @@ serverSettings AppConfig{..} =
& setServerName ("postgrest/" <> prettyVersion) & setServerName ("postgrest/" <> prettyVersion)
-- | PostgREST application -- | PostgREST application
postgrest :: LogLevel -> AppState.AppState -> IO () -> (Observation -> IO ()) -> Wai.Application postgrest :: LogLevel -> AppState.AppState -> IO () -> Wai.Application
postgrest logLevel appState connWorker observer = postgrest logLevel appState connWorker =
traceHeaderMiddleware appState . traceHeaderMiddleware appState .
Cors.middleware appState . Cors.middleware appState .
Auth.middleware appState . Auth.middleware appState .
@@ -109,7 +110,7 @@ postgrest logLevel appState connWorker observer =
let let
eitherResponse :: IO (Either Error Wai.Response) eitherResponse :: IO (Either Error Wai.Response)
eitherResponse = eitherResponse =
runExceptT $ postgrestResponse appState appConf maybeSchemaCache pgVer authResult req observer runExceptT $ postgrestResponse appState appConf maybeSchemaCache pgVer authResult req
response <- either Error.errorResponseFor identity <$> eitherResponse response <- either Error.errorResponseFor identity <$> eitherResponse
-- Launch the connWorker when the connection is down. The postgrest -- Launch the connWorker when the connection is down. The postgrest
@@ -128,9 +129,8 @@ postgrestResponse
-> PgVersion -> PgVersion
-> AuthResult -> AuthResult
-> Wai.Request -> Wai.Request
-> (Observation -> IO ())
-> Handler IO Wai.Response -> Handler IO Wai.Response
postgrestResponse appState conf@AppConfig{..} maybeSchemaCache pgVer authResult@AuthResult{..} req observer = do postgrestResponse appState conf@AppConfig{..} maybeSchemaCache pgVer authResult@AuthResult{..} req = do
sCache <- sCache <-
case maybeSchemaCache of case maybeSchemaCache of
Just sCache -> Just sCache ->
@@ -144,7 +144,7 @@ postgrestResponse appState conf@AppConfig{..} maybeSchemaCache pgVer authResult@
(parseTime, apiReq@ApiRequest{..}) <- withTiming $ liftEither . mapLeft Error.ApiRequestError $ ApiRequest.userApiRequest conf req body sCache (parseTime, apiReq@ApiRequest{..}) <- withTiming $ liftEither . mapLeft Error.ApiRequestError $ ApiRequest.userApiRequest conf req body sCache
(planTime, plan) <- withTiming $ liftEither $ Plan.actionPlan iAction conf apiReq sCache (planTime, plan) <- withTiming $ liftEither $ Plan.actionPlan iAction conf apiReq sCache
(queryTime, queryResult) <- withTiming $ Query.runQuery appState conf authResult apiReq plan sCache pgVer (Just authRole /= configDbAnonRole) observer (queryTime, queryResult) <- withTiming $ Query.runQuery appState conf authResult apiReq plan sCache pgVer (Just authRole /= configDbAnonRole)
(respTime, resp) <- withTiming $ liftEither $ Response.actionResponse queryResult apiReq (T.decodeUtf8 prettyVersion, docsVersion) conf sCache iSchema iNegotiatedByProfile (respTime, resp) <- withTiming $ liftEither $ Response.actionResponse queryResult apiReq (T.decodeUtf8 prettyVersion, docsVersion) conf sCache iSchema iNegotiatedByProfile
return $ toWaiResponse (ServerTiming jwtTime parseTime planTime queryTime respTime) resp return $ toWaiResponse (ServerTiming jwtTime parseTime planTime queryTime respTime) resp
+36 -37
View File
@@ -24,7 +24,6 @@ module PostgREST.AppState
, putSchemaCache , putSchemaCache
, putPgVersion , putPgVersion
, usePool , usePool
, loadSchemaCache
, reReadConfig , reReadConfig
, connectionWorker , connectionWorker
, runListener , runListener
@@ -67,7 +66,8 @@ import PostgREST.Config.Database (queryDbSettings,
import PostgREST.Config.PgVersion (PgVersion (..), import PostgREST.Config.PgVersion (PgVersion (..),
minimumPgVersion) minimumPgVersion)
import PostgREST.SchemaCache (SchemaCache (..), import PostgREST.SchemaCache (SchemaCache (..),
querySchemaCache) querySchemaCache,
showSummary)
import PostgREST.SchemaCache.Identifiers (dumpQi) import PostgREST.SchemaCache.Identifiers (dumpQi)
import PostgREST.Unix (createAndBindDomainSocket) import PostgREST.Unix (createAndBindDomainSocket)
@@ -115,15 +115,15 @@ data AppState = AppState
type AppSockets = (NS.Socket, Maybe NS.Socket) type AppSockets = (NS.Socket, Maybe NS.Socket)
init :: AppConfig -> (Observation -> IO ()) -> IO AppState init :: AppConfig -> IO AppState
init conf observer = do init conf = do
pool <- initPool conf pool <- initPool conf
(sock, adminSock) <- initSockets conf (sock, adminSock) <- initSockets conf
state' <- initWithPool (sock, adminSock) pool conf observer state' <- initWithPool (sock, adminSock) pool conf
pure state' { stateSocketREST = sock, stateSocketAdmin = adminSock } pure state' { stateSocketREST = sock, stateSocketAdmin = adminSock }
initWithPool :: AppSockets -> SQL.Pool -> AppConfig -> (Observation -> IO() ) -> IO AppState initWithPool :: AppSockets -> SQL.Pool -> AppConfig -> IO AppState
initWithPool (sock, adminSock) pool conf observer = do initWithPool (sock, adminSock) pool conf@AppConfig{configObserver=observer} = do
appState <- AppState pool appState <- AppState pool
<$> newIORef minimumPgVersion -- assume we're in a supported version when starting, this will be corrected on a later step <$> newIORef minimumPgVersion -- assume we're in a supported version when starting, this will be corrected on a later step
<*> newIORef Nothing <*> newIORef Nothing
@@ -152,7 +152,7 @@ initWithPool (sock, adminSock) pool conf observer = do
debWorker <- debWorker <-
let decisecond = 100000 in let decisecond = 100000 in
mkDebounce defaultDebounceSettings mkDebounce defaultDebounceSettings
{ debounceAction = internalConnectionWorker appState observer { debounceAction = internalConnectionWorker appState
, debounceFreq = decisecond , debounceFreq = decisecond
, debounceEdge = leadingEdge -- runs the worker at the start and the end , debounceEdge = leadingEdge -- runs the worker at the start and the end
} }
@@ -205,8 +205,8 @@ initPool AppConfig{..} =
(toUtf8 $ addFallbackAppName prettyVersion configDbUri) (toUtf8 $ addFallbackAppName prettyVersion configDbUri)
-- | Run an action with a database connection. -- | Run an action with a database connection.
usePool :: AppState -> AppConfig -> SQL.Session a -> (Observation -> IO ()) -> IO (Either SQL.UsageError a) usePool :: AppState -> AppConfig -> SQL.Session a -> IO (Either SQL.UsageError a)
usePool AppState{..} AppConfig{configLogLevel} sess observer = do usePool AppState{..} AppConfig{configLogLevel, configObserver=observer} sess = do
res <- SQL.use statePool sess res <- SQL.use statePool sess
when (configLogLevel > LogCrit) $ do when (configLogLevel > LogCrit) $ do
@@ -301,12 +301,12 @@ data SCacheStatus
| SCFatalFail | SCFatalFail
-- | Load the SchemaCache by using a connection from the pool. -- | Load the SchemaCache by using a connection from the pool.
loadSchemaCache :: AppState -> (Observation -> IO()) -> IO SCacheStatus loadSchemaCache :: AppState -> AppConfig -> IO SCacheStatus
loadSchemaCache appState observer = do loadSchemaCache appState AppConfig{configObserver=observer} = do
conf@AppConfig{..} <- getConfig appState conf@AppConfig{..} <- getConfig appState
(resultTime, result) <- (resultTime, result) <-
let transaction = if configDbPreparedStatements then SQL.transaction else SQL.unpreparedTransaction in let transaction = if configDbPreparedStatements then SQL.transaction else SQL.unpreparedTransaction in
timeItT $ usePool appState conf (transaction SQL.ReadCommitted SQL.Read $ querySchemaCache conf) observer timeItT $ usePool appState conf (transaction SQL.ReadCommitted SQL.Read $ querySchemaCache conf)
case result of case result of
Left e -> do Left e -> do
case checkIsFatal e of case checkIsFatal e of
@@ -322,7 +322,7 @@ loadSchemaCache appState observer = do
Right sCache -> do Right sCache -> do
putSchemaCache appState $ Just sCache putSchemaCache appState $ Just sCache
observer $ SchemaCacheQueriedObs resultTime observer $ SchemaCacheQueriedObs resultTime
(t, _) <- timeItT $ observer $ SchemaCacheSummaryObs sCache (t, _) <- timeItT $ observer $ SchemaCacheSummaryObs $ showSummary sCache
observer $ SchemaCacheLoadedObs t observer $ SchemaCacheLoadedObs t
putSchemaCacheLoaded appState True putSchemaCacheLoaded appState True
return SCLoaded return SCLoaded
@@ -345,13 +345,13 @@ data ConnectionStatus
-- 2. Checks if the pg version is supported and if it's not it kills the main -- 2. Checks if the pg version is supported and if it's not it kills the main
-- program. -- program.
-- 3. Obtains the sCache. If this fails, it goes back to 1. -- 3. Obtains the sCache. If this fails, it goes back to 1.
internalConnectionWorker :: AppState -> (Observation -> IO()) -> IO () internalConnectionWorker :: AppState -> IO ()
internalConnectionWorker appState observer = work internalConnectionWorker appState = work
where where
work = do work = do
config@AppConfig{..} <- getConfig appState config@AppConfig{configObserver=observer, ..} <- getConfig appState
observer DBConnectAttemptObs observer DBConnectAttemptObs
connected <- establishConnection appState config observer connected <- establishConnection appState config
case connected of case connected of
FatalConnectionError reason -> FatalConnectionError reason ->
-- Fatal error when connecting -- Fatal error when connecting
@@ -368,8 +368,8 @@ internalConnectionWorker appState observer = work
observer (DBConnectedObs $ pgvFullName actualPgVersion) observer (DBConnectedObs $ pgvFullName actualPgVersion)
-- this could be fail because the connection drops, but the loadSchemaCache will pick the error and retry again -- 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. -- 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 observer when configDbConfig $ reReadConfig False appState
scStatus <- loadSchemaCache appState observer scStatus <- loadSchemaCache appState config
case scStatus of case scStatus of
SCLoaded -> SCLoaded ->
-- do nothing and proceed if the load was successful -- do nothing and proceed if the load was successful
@@ -391,8 +391,8 @@ internalConnectionWorker appState observer = work
-- --
-- The connection tries are capped, but if the connection times out no error is -- The connection tries are capped, but if the connection times out no error is
-- thrown, just 'False' is returned. -- thrown, just 'False' is returned.
establishConnection :: AppState -> AppConfig -> (Observation -> IO ()) -> IO ConnectionStatus establishConnection :: AppState -> AppConfig -> IO ConnectionStatus
establishConnection appState config observer = establishConnection appState config@AppConfig{configObserver=observer} =
retrying retrySettings shouldRetry $ retrying retrySettings shouldRetry $
const $ flushPool appState >> getConnectionStatus const $ flushPool appState >> getConnectionStatus
where where
@@ -402,7 +402,7 @@ establishConnection appState config observer =
getConnectionStatus :: IO ConnectionStatus getConnectionStatus :: IO ConnectionStatus
getConnectionStatus = do getConnectionStatus = do
pgVersion <- usePool appState config (queryPgVersion False) observer -- No need to prepare the query here, as the connection might not be established pgVersion <- usePool appState config (queryPgVersion False) -- No need to prepare the query here, as the connection might not be established
case pgVersion of case pgVersion of
Left e -> do Left e -> do
observer $ ConnectionPgVersionErrorObs e observer $ ConnectionPgVersionErrorObs e
@@ -430,13 +430,13 @@ establishConnection appState config observer =
return itShould return itShould
-- | Re-reads the config plus config options from the db -- | Re-reads the config plus config options from the db
reReadConfig :: Bool -> AppState -> (Observation -> IO ()) -> IO () reReadConfig :: Bool -> AppState -> IO ()
reReadConfig startingUp appState observer = do reReadConfig startingUp appState = do
config@AppConfig{..} <- getConfig appState config@AppConfig{configObserver=observer, ..} <- getConfig appState
pgVer <- getPgVersion appState pgVer <- getPgVersion appState
dbSettings <- dbSettings <-
if configDbConfig then do if configDbConfig then do
qDbSettings <- usePool appState config (queryDbSettings (dumpQi <$> configDbPreConfig) configDbPreparedStatements) observer qDbSettings <- usePool appState config (queryDbSettings (dumpQi <$> configDbPreConfig) configDbPreparedStatements)
case qDbSettings of case qDbSettings of
Left e -> do Left e -> do
observer ConfigReadErrorObs observer ConfigReadErrorObs
@@ -452,7 +452,7 @@ reReadConfig startingUp appState observer = do
pure mempty pure mempty
(roleSettings, roleIsolationLvl) <- (roleSettings, roleIsolationLvl) <-
if configDbConfig then do if configDbConfig then do
rSettings <- usePool appState config (queryRoleSettings pgVer configDbPreparedStatements) observer rSettings <- usePool appState config (queryRoleSettings pgVer configDbPreparedStatements)
case rSettings of case rSettings of
Left e -> do Left e -> do
observer $ QueryRoleSettingsErrorObs e observer $ QueryRoleSettingsErrorObs e
@@ -460,7 +460,7 @@ reReadConfig startingUp appState observer = do
Right x -> pure x Right x -> pure x
else else
pure mempty pure mempty
readAppConfig dbSettings configFilePath (Just configDbUri) roleSettings roleIsolationLvl >>= \case readAppConfig dbSettings configFilePath (Just configDbUri) roleSettings roleIsolationLvl observer >>= \case
Left err -> Left err ->
if startingUp then if startingUp then
panic err -- die on invalid config if the program is starting up panic err -- die on invalid config if the program is starting up
@@ -473,16 +473,15 @@ reReadConfig startingUp appState observer = do
else else
observer ConfigSucceededObs observer ConfigSucceededObs
runListener :: AppConfig -> AppState -> (Observation -> IO ()) -> IO () runListener :: AppConfig -> AppState -> IO ()
runListener AppConfig{configDbChannelEnabled} appState observer = runListener conf@AppConfig{configDbChannelEnabled} appState = do
when configDbChannelEnabled $ listener appState observer when configDbChannelEnabled $ listener appState conf
-- | Starts a dedicated pg connection to LISTEN for notifications. When a -- | Starts a dedicated pg connection to LISTEN for notifications. When a
-- NOTIFY <db-channel> - with an empty payload - is done, it refills the schema -- NOTIFY <db-channel> - with an empty payload - is done, it refills the schema
-- cache. It uses the connectionWorker in case the LISTEN connection dies. -- cache. It uses the connectionWorker in case the LISTEN connection dies.
listener :: AppState -> (Observation -> IO ()) -> IO () listener :: AppState -> AppConfig -> IO ()
listener appState observer = do listener appState conf@AppConfig{configObserver=observer, ..} = do
AppConfig{..} <- getConfig appState
let dbChannel = toS configDbChannel let dbChannel = toS configDbChannel
-- The listener has to wait for a signal from the connectionWorker. -- The listener has to wait for a signal from the connectionWorker.
@@ -515,12 +514,12 @@ listener appState observer = do
-- assume the pool connection was also lost, call the connection worker -- assume the pool connection was also lost, call the connection worker
connectionWorker appState connectionWorker appState
-- retry the listener -- retry the listener
listener appState observer listener appState conf
handleNotification channel msg = handleNotification channel msg =
if | BS.null msg -> observer (DBListenerGotSCacheMsg channel) >> cacheReloader if | BS.null msg -> observer (DBListenerGotSCacheMsg channel) >> cacheReloader
| msg == "reload schema" -> observer (DBListenerGotSCacheMsg channel) >> cacheReloader | msg == "reload schema" -> observer (DBListenerGotSCacheMsg channel) >> cacheReloader
| msg == "reload config" -> observer (DBListenerGotConfigMsg channel) >> reReadConfig False appState observer | msg == "reload config" -> observer (DBListenerGotConfigMsg channel) >> reReadConfig False appState
| otherwise -> pure () -- Do nothing if anything else than an empty message is sent | otherwise -> pure () -- Do nothing if anything else than an empty message is sent
cacheReloader = cacheReloader =
+7 -7
View File
@@ -32,22 +32,23 @@ import Protolude hiding (hPutStrLn)
main :: CLI -> IO () main :: CLI -> IO ()
main CLI{cliCommand, cliPath} = do main CLI{cliCommand, cliPath} = do
conf@AppConfig{..} <-
either panic identity <$> Config.readAppConfig mempty cliPath Nothing mempty mempty
loggerState <- Logger.init loggerState <- Logger.init
conf@AppConfig{..} <-
either panic identity <$> Config.readAppConfig mempty cliPath Nothing mempty mempty (Logger.observationLogger loggerState)
-- Per https://github.com/PostgREST/postgrest/issues/268, we want to -- Per https://github.com/PostgREST/postgrest/issues/268, we want to
-- explicitly close the connections to PostgreSQL on shutdown. -- explicitly close the connections to PostgreSQL on shutdown.
-- 'AppState.destroy' takes care of that. -- 'AppState.destroy' takes care of that.
bracket bracket
(AppState.init conf $ Logger.logObservation loggerState) (AppState.init conf)
AppState.destroy AppState.destroy
(\appState -> case cliCommand of (\appState -> case cliCommand of
CmdDumpConfig -> do CmdDumpConfig -> do
when configDbConfig $ AppState.reReadConfig True appState (const $ pure ()) when configDbConfig $ AppState.reReadConfig True appState
putStr . Config.toText =<< AppState.getConfig appState putStr . Config.toText =<< AppState.getConfig appState
CmdDumpSchema -> putStrLn =<< dumpSchema appState CmdDumpSchema -> putStrLn =<< dumpSchema appState
CmdRun -> App.run appState (Logger.logObservation loggerState)) CmdRun -> App.run appState)
-- | Dump SchemaCache schema to JSON -- | Dump SchemaCache schema to JSON
dumpSchema :: AppState -> IO LBS.ByteString dumpSchema :: AppState -> IO LBS.ByteString
@@ -57,7 +58,6 @@ dumpSchema appState = do
let transaction = if configDbPreparedStatements then SQL.transaction else SQL.unpreparedTransaction in let transaction = if configDbPreparedStatements then SQL.transaction else SQL.unpreparedTransaction in
AppState.usePool appState conf AppState.usePool appState conf
(transaction SQL.ReadCommitted SQL.Read $ querySchemaCache conf) (transaction SQL.ReadCommitted SQL.Read $ querySchemaCache conf)
(const $ pure ())
case result of case result of
Left e -> do Left e -> do
hPutStrLn stderr $ "An error ocurred when loading the schema cache:\n" <> show e hPutStrLn stderr $ "An error ocurred when loading the schema cache:\n" <> show e
+9 -5
View File
@@ -64,6 +64,8 @@ import PostgREST.Config.Proxy (Proxy (..),
import PostgREST.SchemaCache.Identifiers (QualifiedIdentifier, dumpQi, import PostgREST.SchemaCache.Identifiers (QualifiedIdentifier, dumpQi,
toQi) toQi)
import PostgREST.Observation
import Protolude hiding (Proxy, toList) import Protolude hiding (Proxy, toList)
@@ -112,6 +114,7 @@ data AppConfig = AppConfig
, configRoleSettings :: RoleSettings , configRoleSettings :: RoleSettings
, configRoleIsoLvl :: RoleIsolationLvl , configRoleIsoLvl :: RoleIsolationLvl
, configInternalSCSleep :: Maybe Int32 , configInternalSCSleep :: Maybe Int32
, configObserver :: ObservationHandler
} }
data LogLevel = LogCrit | LogError | LogWarn | LogInfo data LogLevel = LogCrit | LogError | LogWarn | LogInfo
@@ -210,13 +213,13 @@ instance JustIfMaybe a (Maybe a) where
-- | Reads and parses the config and overrides its parameters from env vars, -- | Reads and parses the config and overrides its parameters from env vars,
-- files or db settings. -- files or db settings.
readAppConfig :: [(Text, Text)] -> Maybe FilePath -> Maybe Text -> RoleSettings -> RoleIsolationLvl -> IO (Either Text AppConfig) readAppConfig :: [(Text, Text)] -> Maybe FilePath -> Maybe Text -> RoleSettings -> RoleIsolationLvl -> ObservationHandler -> IO (Either Text AppConfig)
readAppConfig dbSettings optPath prevDbUri roleSettings roleIsolationLvl = do readAppConfig dbSettings optPath prevDbUri roleSettings roleIsolationLvl observer = do
env <- readPGRSTEnvironment env <- readPGRSTEnvironment
-- if no filename provided, start with an empty map to read config from environment -- if no filename provided, start with an empty map to read config from environment
conf <- maybe (return $ Right M.empty) loadConfig optPath conf <- maybe (return $ Right M.empty) loadConfig optPath
case C.runParser (parser optPath env dbSettings roleSettings roleIsolationLvl) =<< mapLeft show conf of case C.runParser (parser optPath env dbSettings roleSettings roleIsolationLvl observer) =<< mapLeft show conf of
Left err -> Left err ->
return . Left $ "Error in config " <> err return . Left $ "Error in config " <> err
Right parsedConfig -> Right parsedConfig ->
@@ -231,8 +234,8 @@ readAppConfig dbSettings optPath prevDbUri roleSettings roleIsolationLvl = do
decodeJWKS <$> decodeJWKS <$>
(decodeSecret =<< readSecretFile =<< readDbUriFile prevDbUri parsedConfig) (decodeSecret =<< readSecretFile =<< readDbUriFile prevDbUri parsedConfig)
parser :: Maybe FilePath -> Environment -> [(Text, Text)] -> RoleSettings -> RoleIsolationLvl -> C.Parser C.Config AppConfig parser :: Maybe FilePath -> Environment -> [(Text, Text)] -> RoleSettings -> RoleIsolationLvl -> ObservationHandler -> C.Parser C.Config AppConfig
parser optPath env dbSettings roleSettings roleIsolationLvl = parser optPath env dbSettings roleSettings roleIsolationLvl observer =
AppConfig AppConfig
<$> parseAppSettings "app.settings" <$> parseAppSettings "app.settings"
<*> (fromMaybe False <$> optBool "db-aggregates-enabled") <*> (fromMaybe False <$> optBool "db-aggregates-enabled")
@@ -285,6 +288,7 @@ parser optPath env dbSettings roleSettings roleIsolationLvl =
<*> pure roleSettings <*> pure roleSettings
<*> pure roleIsolationLvl <*> pure roleIsolationLvl
<*> optInt "internal-schema-cache-sleep" <*> optInt "internal-schema-cache-sleep"
<*> pure observer
where where
parseAppSettings :: C.Key -> C.Parser C.Config [(Text, Text)] parseAppSettings :: C.Key -> C.Parser C.Config [(Text, Text)]
parseAppSettings key = addFromEnv . fmap (fmap coerceText) <$> C.subassocs key C.value parseAppSettings key = addFromEnv . fmap (fmap coerceText) <$> C.subassocs key C.value
+3 -3
View File
@@ -4,7 +4,7 @@ Description : Wai Middleware to log requests to stdout.
-} -}
module PostgREST.Logger module PostgREST.Logger
( middleware ( middleware
, logObservation , observationLogger
, init , init
) where ) where
@@ -50,8 +50,8 @@ middleware logLevel = case logLevel of
& Wai.setApacheUserGetter Auth.getRole & Wai.setApacheUserGetter Auth.getRole
} }
logObservation :: LoggerState -> Observation -> IO () observationLogger :: LoggerState -> ObservationHandler
logObservation loggerState obs = logWithZTime loggerState $ observationMessage obs observationLogger loggerState obs = logWithZTime loggerState $ observationMessage obs
logWithZTime :: LoggerState -> Text -> IO () logWithZTime :: LoggerState -> Text -> IO ()
logWithZTime loggerState txt = do logWithZTime loggerState txt = do
+14 -12
View File
@@ -6,17 +6,17 @@ Description : Module for observability types
module PostgREST.Observation module PostgREST.Observation
( Observation(..) ( Observation(..)
, observationMessage , observationMessage
, ObservationHandler
) where ) where
import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy as LBS
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Encoding as T import qualified Data.Text.Encoding as T
import qualified Hasql.Connection as SQL import qualified Hasql.Connection as SQL
import qualified Hasql.Pool as SQL import qualified Hasql.Pool as SQL
import qualified Network.Socket as NS import qualified Network.Socket as NS
import Numeric (showFFloat) import Numeric (showFFloat)
import qualified PostgREST.Error as Error import qualified PostgREST.Error as Error
import PostgREST.SchemaCache (SchemaCache, showSummary)
import Protolude import Protolude
import Protolude.Partial (fromJust) import Protolude.Partial (fromJust)
@@ -33,7 +33,7 @@ data Observation
| SchemaCacheFatalErrorObs SQL.UsageError Text | SchemaCacheFatalErrorObs SQL.UsageError Text
| SchemaCacheNormalErrorObs SQL.UsageError | SchemaCacheNormalErrorObs SQL.UsageError
| SchemaCacheQueriedObs Double | SchemaCacheQueriedObs Double
| SchemaCacheSummaryObs SchemaCache | SchemaCacheSummaryObs Text
| SchemaCacheLoadedObs Double | SchemaCacheLoadedObs Double
| ConnectionRetryObs Int | ConnectionRetryObs Int
| ConnectionPgVersionErrorObs SQL.UsageError | ConnectionPgVersionErrorObs SQL.UsageError
@@ -51,6 +51,8 @@ data Observation
| QueryErrorCodeHighObs SQL.UsageError | QueryErrorCodeHighObs SQL.UsageError
| PoolAcqTimeoutObs SQL.UsageError | PoolAcqTimeoutObs SQL.UsageError
type ObservationHandler = Observation -> IO ()
observationMessage :: Observation -> Text observationMessage :: Observation -> Text
observationMessage = \case observationMessage = \case
AdminStartObs port -> AdminStartObs port ->
@@ -75,8 +77,8 @@ observationMessage = \case
"An error ocurred when loading the schema cache. " <> jsonMessage usageErr "An error ocurred when loading the schema cache. " <> jsonMessage usageErr
SchemaCacheQueriedObs resultTime -> SchemaCacheQueriedObs resultTime ->
"Schema cache queried in " <> showMillis resultTime <> " milliseconds" "Schema cache queried in " <> showMillis resultTime <> " milliseconds"
SchemaCacheSummaryObs sCache -> SchemaCacheSummaryObs summary ->
"Schema cache loaded " <> showSummary sCache "Schema cache loaded " <> summary
SchemaCacheLoadedObs resultTime -> SchemaCacheLoadedObs resultTime ->
"Schema cache loaded in " <> showMillis resultTime <> " milliseconds" "Schema cache loaded in " <> showMillis resultTime <> " milliseconds"
ConnectionRetryObs delay -> ConnectionRetryObs delay ->
+4 -5
View File
@@ -43,7 +43,6 @@ import PostgREST.Config (AppConfig (..),
import PostgREST.Config.PgVersion (PgVersion (..)) import PostgREST.Config.PgVersion (PgVersion (..))
import PostgREST.Error (Error) import PostgREST.Error (Error)
import PostgREST.MediaType (MediaType (..)) import PostgREST.MediaType (MediaType (..))
import PostgREST.Observation (Observation (..))
import PostgREST.Plan (ActionPlan (..), import PostgREST.Plan (ActionPlan (..),
CallReadPlan (..), CallReadPlan (..),
CrudPlan (..), CrudPlan (..),
@@ -75,12 +74,12 @@ data QueryResult
| NoDbResult InfoPlan | NoDbResult InfoPlan
-- TODO This function needs to be free from IO, only App.hs should do IO -- TODO This function needs to be free from IO, only App.hs should do IO
runQuery :: AppState.AppState -> AppConfig -> AuthResult -> ApiRequest -> ActionPlan -> SchemaCache -> PgVersion -> Bool -> (Observation -> IO ()) -> ExceptT Error IO QueryResult runQuery :: AppState.AppState -> AppConfig -> AuthResult -> ApiRequest -> ActionPlan -> SchemaCache -> PgVersion -> Bool -> ExceptT Error IO QueryResult
runQuery _ _ _ _ (NoDb x) _ _ _ _ = pure $ NoDbResult x runQuery _ _ _ _ (NoDb x) _ _ _ = pure $ NoDbResult x
runQuery appState config AuthResult{..} apiReq (Db plan) sCache pgVer authenticated observer = do runQuery appState config AuthResult{..} apiReq (Db plan) sCache pgVer authenticated = do
dbResp <- lift $ do dbResp <- lift $ do
let transaction = if prepared then SQL.transaction else SQL.unpreparedTransaction let transaction = if prepared then SQL.transaction else SQL.unpreparedTransaction
AppState.usePool appState config (transaction isoLvl txMode $ runExceptT dbHandler) observer AppState.usePool appState config (transaction isoLvl txMode $ runExceptT dbHandler)
resp <- resp <-
liftEither . mapLeft Error.PgErr $ liftEither . mapLeft Error.PgErr $
+4 -5
View File
@@ -77,21 +77,20 @@ main = do
sockets <- AppState.initSockets testCfg sockets <- AppState.initSockets testCfg
let let
noObs = const $ pure ()
-- For tests that run with the same refSchemaCache -- For tests that run with the same refSchemaCache
app config = do app config = do
appState <- AppState.initWithPool sockets pool config noObs appState <- AppState.initWithPool sockets pool config
AppState.putPgVersion appState actualPgVersion AppState.putPgVersion appState actualPgVersion
AppState.putSchemaCache appState (Just baseSchemaCache) AppState.putSchemaCache appState (Just baseSchemaCache)
return ((), postgrest (configLogLevel config) appState (pure ()) noObs) return ((), postgrest (configLogLevel config) appState (pure ()))
-- For tests that run with a different SchemaCache(depends on configSchemas) -- For tests that run with a different SchemaCache(depends on configSchemas)
appDbs config = do appDbs config = do
customSchemaCache <- loadSCache pool config customSchemaCache <- loadSCache pool config
appState <- AppState.initWithPool sockets pool config noObs appState <- AppState.initWithPool sockets pool config
AppState.putPgVersion appState actualPgVersion AppState.putPgVersion appState actualPgVersion
AppState.putSchemaCache appState (Just customSchemaCache) AppState.putSchemaCache appState (Just customSchemaCache)
return ((), postgrest (configLogLevel config) appState (pure ()) noObs) return ((), postgrest (configLogLevel config) appState (pure ()))
let withApp = app testCfg let withApp = app testCfg
maxRowsApp = app testMaxRowsCfg maxRowsApp = app testMaxRowsCfg
+1
View File
@@ -141,6 +141,7 @@ baseCfg = let secret = Just $ encodeUtf8 "reallyreallyreallyreallyverysafe" in
, configRoleIsoLvl = mempty , configRoleIsoLvl = mempty
, configInternalSCSleep = Nothing , configInternalSCSleep = Nothing
, configServerTimingEnabled = True , configServerTimingEnabled = True
, configObserver = const $ pure ()
} }
testCfg :: AppConfig testCfg :: AppConfig