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
committed by
Steve Chavez
Steve Chavez
parent
460259548d
commit
2de32fc108
@@ -26,23 +26,23 @@ import qualified PostgREST.Config as Config
|
||||
|
||||
import Protolude
|
||||
|
||||
runAdmin :: AppConfig -> AppState -> Warp.Settings -> (Observation -> IO ()) -> IO ()
|
||||
runAdmin conf@AppConfig{configAdminServerPort} appState settings observer =
|
||||
runAdmin :: AppConfig -> AppState -> Warp.Settings -> IO ()
|
||||
runAdmin conf@AppConfig{configAdminServerPort, configObserver=observer} appState settings =
|
||||
whenJust (AppState.getSocketAdmin appState) $ \adminSocket -> do
|
||||
observer $ AdminStartObs configAdminServerPort
|
||||
void . forkIO $ Warp.runSettingsSocket settings adminSocket adminApp
|
||||
where
|
||||
adminApp = admin appState conf observer
|
||||
adminApp = admin appState conf
|
||||
|
||||
-- | PostgREST admin application
|
||||
admin :: AppState.AppState -> AppConfig -> (Observation -> IO ()) -> Wai.Application
|
||||
admin appState appConfig observer req respond = do
|
||||
admin :: AppState.AppState -> AppConfig -> Wai.Application
|
||||
admin appState appConfig req respond = do
|
||||
isMainAppReachable <- isRight <$> reachMainApp (AppState.getSocketREST appState)
|
||||
isSchemaCacheLoaded <- AppState.getSchemaCacheLoaded appState
|
||||
isConnectionUp <-
|
||||
if configDbChannelEnabled appConfig
|
||||
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
|
||||
["ready"] ->
|
||||
|
||||
+13
-13
@@ -60,19 +60,20 @@ import System.TimeIt (timeItT)
|
||||
|
||||
type Handler = ExceptT Error
|
||||
|
||||
run :: AppState -> (Observation -> IO ()) -> IO ()
|
||||
run appState observer = do
|
||||
run :: AppState -> IO ()
|
||||
run appState = do
|
||||
conf@AppConfig{configObserver=observer, ..} <- AppState.getConfig appState
|
||||
|
||||
observer $ AppServerStartObs prettyVersion
|
||||
|
||||
conf@AppConfig{..} <- AppState.getConfig appState
|
||||
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
|
||||
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
|
||||
Just path -> do
|
||||
@@ -91,8 +92,8 @@ serverSettings AppConfig{..} =
|
||||
& setServerName ("postgrest/" <> prettyVersion)
|
||||
|
||||
-- | PostgREST application
|
||||
postgrest :: LogLevel -> AppState.AppState -> IO () -> (Observation -> IO ()) -> Wai.Application
|
||||
postgrest logLevel appState connWorker observer =
|
||||
postgrest :: LogLevel -> AppState.AppState -> IO () -> Wai.Application
|
||||
postgrest logLevel appState connWorker =
|
||||
traceHeaderMiddleware appState .
|
||||
Cors.middleware appState .
|
||||
Auth.middleware appState .
|
||||
@@ -109,7 +110,7 @@ postgrest logLevel appState connWorker observer =
|
||||
let
|
||||
eitherResponse :: IO (Either Error Wai.Response)
|
||||
eitherResponse =
|
||||
runExceptT $ postgrestResponse appState appConf maybeSchemaCache pgVer authResult req observer
|
||||
runExceptT $ postgrestResponse appState appConf maybeSchemaCache pgVer authResult req
|
||||
|
||||
response <- either Error.errorResponseFor identity <$> eitherResponse
|
||||
-- Launch the connWorker when the connection is down. The postgrest
|
||||
@@ -128,9 +129,8 @@ postgrestResponse
|
||||
-> PgVersion
|
||||
-> AuthResult
|
||||
-> Wai.Request
|
||||
-> (Observation -> IO ())
|
||||
-> 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 <-
|
||||
case maybeSchemaCache of
|
||||
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
|
||||
(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
|
||||
|
||||
return $ toWaiResponse (ServerTiming jwtTime parseTime planTime queryTime respTime) resp
|
||||
|
||||
+36
-37
@@ -24,7 +24,6 @@ module PostgREST.AppState
|
||||
, putSchemaCache
|
||||
, putPgVersion
|
||||
, usePool
|
||||
, loadSchemaCache
|
||||
, reReadConfig
|
||||
, connectionWorker
|
||||
, runListener
|
||||
@@ -67,7 +66,8 @@ import PostgREST.Config.Database (queryDbSettings,
|
||||
import PostgREST.Config.PgVersion (PgVersion (..),
|
||||
minimumPgVersion)
|
||||
import PostgREST.SchemaCache (SchemaCache (..),
|
||||
querySchemaCache)
|
||||
querySchemaCache,
|
||||
showSummary)
|
||||
import PostgREST.SchemaCache.Identifiers (dumpQi)
|
||||
import PostgREST.Unix (createAndBindDomainSocket)
|
||||
|
||||
@@ -115,15 +115,15 @@ data AppState = AppState
|
||||
|
||||
type AppSockets = (NS.Socket, Maybe NS.Socket)
|
||||
|
||||
init :: AppConfig -> (Observation -> IO ()) -> IO AppState
|
||||
init conf observer = do
|
||||
init :: AppConfig -> IO AppState
|
||||
init conf = do
|
||||
pool <- initPool conf
|
||||
(sock, adminSock) <- initSockets conf
|
||||
state' <- initWithPool (sock, adminSock) pool conf observer
|
||||
state' <- initWithPool (sock, adminSock) pool conf
|
||||
pure state' { stateSocketREST = sock, stateSocketAdmin = adminSock }
|
||||
|
||||
initWithPool :: AppSockets -> SQL.Pool -> AppConfig -> (Observation -> IO() ) -> IO AppState
|
||||
initWithPool (sock, adminSock) pool conf observer = do
|
||||
initWithPool :: AppSockets -> SQL.Pool -> AppConfig -> IO AppState
|
||||
initWithPool (sock, adminSock) pool conf@AppConfig{configObserver=observer} = 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
|
||||
@@ -152,7 +152,7 @@ initWithPool (sock, adminSock) pool conf observer = do
|
||||
debWorker <-
|
||||
let decisecond = 100000 in
|
||||
mkDebounce defaultDebounceSettings
|
||||
{ debounceAction = internalConnectionWorker appState observer
|
||||
{ debounceAction = internalConnectionWorker appState
|
||||
, debounceFreq = decisecond
|
||||
, debounceEdge = leadingEdge -- runs the worker at the start and the end
|
||||
}
|
||||
@@ -205,8 +205,8 @@ initPool AppConfig{..} =
|
||||
(toUtf8 $ addFallbackAppName prettyVersion configDbUri)
|
||||
|
||||
-- | Run an action with a database connection.
|
||||
usePool :: AppState -> AppConfig -> SQL.Session a -> (Observation -> IO ()) -> IO (Either SQL.UsageError a)
|
||||
usePool AppState{..} AppConfig{configLogLevel} sess observer = do
|
||||
usePool :: AppState -> AppConfig -> SQL.Session a -> IO (Either SQL.UsageError a)
|
||||
usePool AppState{..} AppConfig{configLogLevel, configObserver=observer} sess = do
|
||||
res <- SQL.use statePool sess
|
||||
|
||||
when (configLogLevel > LogCrit) $ do
|
||||
@@ -301,12 +301,12 @@ data SCacheStatus
|
||||
| SCFatalFail
|
||||
|
||||
-- | Load the SchemaCache by using a connection from the pool.
|
||||
loadSchemaCache :: AppState -> (Observation -> IO()) -> IO SCacheStatus
|
||||
loadSchemaCache appState observer = do
|
||||
loadSchemaCache :: AppState -> AppConfig -> IO SCacheStatus
|
||||
loadSchemaCache appState AppConfig{configObserver=observer} = do
|
||||
conf@AppConfig{..} <- getConfig appState
|
||||
(resultTime, result) <-
|
||||
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
|
||||
Left e -> do
|
||||
case checkIsFatal e of
|
||||
@@ -322,7 +322,7 @@ loadSchemaCache appState observer = do
|
||||
Right sCache -> do
|
||||
putSchemaCache appState $ Just sCache
|
||||
observer $ SchemaCacheQueriedObs resultTime
|
||||
(t, _) <- timeItT $ observer $ SchemaCacheSummaryObs sCache
|
||||
(t, _) <- timeItT $ observer $ SchemaCacheSummaryObs $ showSummary sCache
|
||||
observer $ SchemaCacheLoadedObs t
|
||||
putSchemaCacheLoaded appState True
|
||||
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
|
||||
-- program.
|
||||
-- 3. Obtains the sCache. If this fails, it goes back to 1.
|
||||
internalConnectionWorker :: AppState -> (Observation -> IO()) -> IO ()
|
||||
internalConnectionWorker appState observer = work
|
||||
internalConnectionWorker :: AppState -> IO ()
|
||||
internalConnectionWorker appState = work
|
||||
where
|
||||
work = do
|
||||
config@AppConfig{..} <- getConfig appState
|
||||
config@AppConfig{configObserver=observer, ..} <- getConfig appState
|
||||
observer DBConnectAttemptObs
|
||||
connected <- establishConnection appState config observer
|
||||
connected <- establishConnection appState config
|
||||
case connected of
|
||||
FatalConnectionError reason ->
|
||||
-- Fatal error when connecting
|
||||
@@ -368,8 +368,8 @@ internalConnectionWorker appState observer = work
|
||||
observer (DBConnectedObs $ pgvFullName actualPgVersion)
|
||||
-- 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 observer
|
||||
scStatus <- loadSchemaCache appState observer
|
||||
when configDbConfig $ reReadConfig False appState
|
||||
scStatus <- loadSchemaCache appState config
|
||||
case scStatus of
|
||||
SCLoaded ->
|
||||
-- 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
|
||||
-- thrown, just 'False' is returned.
|
||||
establishConnection :: AppState -> AppConfig -> (Observation -> IO ()) -> IO ConnectionStatus
|
||||
establishConnection appState config observer =
|
||||
establishConnection :: AppState -> AppConfig -> IO ConnectionStatus
|
||||
establishConnection appState config@AppConfig{configObserver=observer} =
|
||||
retrying retrySettings shouldRetry $
|
||||
const $ flushPool appState >> getConnectionStatus
|
||||
where
|
||||
@@ -402,7 +402,7 @@ establishConnection appState config observer =
|
||||
|
||||
getConnectionStatus :: IO ConnectionStatus
|
||||
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
|
||||
Left e -> do
|
||||
observer $ ConnectionPgVersionErrorObs e
|
||||
@@ -430,13 +430,13 @@ establishConnection appState config observer =
|
||||
return itShould
|
||||
|
||||
-- | Re-reads the config plus config options from the db
|
||||
reReadConfig :: Bool -> AppState -> (Observation -> IO ()) -> IO ()
|
||||
reReadConfig startingUp appState observer = do
|
||||
config@AppConfig{..} <- getConfig appState
|
||||
reReadConfig :: Bool -> AppState -> IO ()
|
||||
reReadConfig startingUp appState = do
|
||||
config@AppConfig{configObserver=observer, ..} <- getConfig appState
|
||||
pgVer <- getPgVersion appState
|
||||
dbSettings <-
|
||||
if configDbConfig then do
|
||||
qDbSettings <- usePool appState config (queryDbSettings (dumpQi <$> configDbPreConfig) configDbPreparedStatements) observer
|
||||
qDbSettings <- usePool appState config (queryDbSettings (dumpQi <$> configDbPreConfig) configDbPreparedStatements)
|
||||
case qDbSettings of
|
||||
Left e -> do
|
||||
observer ConfigReadErrorObs
|
||||
@@ -452,7 +452,7 @@ reReadConfig startingUp appState observer = do
|
||||
pure mempty
|
||||
(roleSettings, roleIsolationLvl) <-
|
||||
if configDbConfig then do
|
||||
rSettings <- usePool appState config (queryRoleSettings pgVer configDbPreparedStatements) observer
|
||||
rSettings <- usePool appState config (queryRoleSettings pgVer configDbPreparedStatements)
|
||||
case rSettings of
|
||||
Left e -> do
|
||||
observer $ QueryRoleSettingsErrorObs e
|
||||
@@ -460,7 +460,7 @@ reReadConfig startingUp appState observer = do
|
||||
Right x -> pure x
|
||||
else
|
||||
pure mempty
|
||||
readAppConfig dbSettings configFilePath (Just configDbUri) roleSettings roleIsolationLvl >>= \case
|
||||
readAppConfig dbSettings configFilePath (Just configDbUri) roleSettings roleIsolationLvl observer >>= \case
|
||||
Left err ->
|
||||
if startingUp then
|
||||
panic err -- die on invalid config if the program is starting up
|
||||
@@ -473,16 +473,15 @@ reReadConfig startingUp appState observer = do
|
||||
else
|
||||
observer ConfigSucceededObs
|
||||
|
||||
runListener :: AppConfig -> AppState -> (Observation -> IO ()) -> IO ()
|
||||
runListener AppConfig{configDbChannelEnabled} appState observer =
|
||||
when configDbChannelEnabled $ listener appState observer
|
||||
runListener :: AppConfig -> AppState -> IO ()
|
||||
runListener conf@AppConfig{configDbChannelEnabled} appState = do
|
||||
when configDbChannelEnabled $ listener appState conf
|
||||
|
||||
-- | 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 -> (Observation -> IO ()) -> IO ()
|
||||
listener appState observer = do
|
||||
AppConfig{..} <- getConfig appState
|
||||
listener :: AppState -> AppConfig -> IO ()
|
||||
listener appState conf@AppConfig{configObserver=observer, ..} = do
|
||||
let dbChannel = toS configDbChannel
|
||||
|
||||
-- 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
|
||||
connectionWorker appState
|
||||
-- retry the listener
|
||||
listener appState observer
|
||||
listener appState conf
|
||||
|
||||
handleNotification channel msg =
|
||||
if | BS.null msg -> 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
|
||||
|
||||
cacheReloader =
|
||||
|
||||
@@ -32,22 +32,23 @@ import Protolude hiding (hPutStrLn)
|
||||
|
||||
main :: CLI -> IO ()
|
||||
main CLI{cliCommand, cliPath} = do
|
||||
conf@AppConfig{..} <-
|
||||
either panic identity <$> Config.readAppConfig mempty cliPath Nothing mempty mempty
|
||||
|
||||
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
|
||||
-- explicitly close the connections to PostgreSQL on shutdown.
|
||||
-- 'AppState.destroy' takes care of that.
|
||||
bracket
|
||||
(AppState.init conf $ Logger.logObservation loggerState)
|
||||
(AppState.init conf)
|
||||
AppState.destroy
|
||||
(\appState -> case cliCommand of
|
||||
CmdDumpConfig -> do
|
||||
when configDbConfig $ AppState.reReadConfig True appState (const $ pure ())
|
||||
when configDbConfig $ AppState.reReadConfig True appState
|
||||
putStr . Config.toText =<< AppState.getConfig appState
|
||||
CmdDumpSchema -> putStrLn =<< dumpSchema appState
|
||||
CmdRun -> App.run appState (Logger.logObservation loggerState))
|
||||
CmdRun -> App.run appState)
|
||||
|
||||
-- | Dump SchemaCache schema to JSON
|
||||
dumpSchema :: AppState -> IO LBS.ByteString
|
||||
@@ -57,7 +58,6 @@ dumpSchema appState = do
|
||||
let transaction = if configDbPreparedStatements then SQL.transaction else SQL.unpreparedTransaction in
|
||||
AppState.usePool appState conf
|
||||
(transaction SQL.ReadCommitted SQL.Read $ querySchemaCache conf)
|
||||
(const $ pure ())
|
||||
case result of
|
||||
Left e -> do
|
||||
hPutStrLn stderr $ "An error ocurred when loading the schema cache:\n" <> show e
|
||||
|
||||
@@ -64,6 +64,8 @@ import PostgREST.Config.Proxy (Proxy (..),
|
||||
import PostgREST.SchemaCache.Identifiers (QualifiedIdentifier, dumpQi,
|
||||
toQi)
|
||||
|
||||
import PostgREST.Observation
|
||||
|
||||
import Protolude hiding (Proxy, toList)
|
||||
|
||||
|
||||
@@ -112,6 +114,7 @@ data AppConfig = AppConfig
|
||||
, configRoleSettings :: RoleSettings
|
||||
, configRoleIsoLvl :: RoleIsolationLvl
|
||||
, configInternalSCSleep :: Maybe Int32
|
||||
, configObserver :: ObservationHandler
|
||||
}
|
||||
|
||||
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,
|
||||
-- files or db settings.
|
||||
readAppConfig :: [(Text, Text)] -> Maybe FilePath -> Maybe Text -> RoleSettings -> RoleIsolationLvl -> IO (Either Text AppConfig)
|
||||
readAppConfig dbSettings optPath prevDbUri roleSettings roleIsolationLvl = do
|
||||
readAppConfig :: [(Text, Text)] -> Maybe FilePath -> Maybe Text -> RoleSettings -> RoleIsolationLvl -> ObservationHandler -> IO (Either Text AppConfig)
|
||||
readAppConfig dbSettings optPath prevDbUri roleSettings roleIsolationLvl observer = do
|
||||
env <- readPGRSTEnvironment
|
||||
-- if no filename provided, start with an empty map to read config from environment
|
||||
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 ->
|
||||
return . Left $ "Error in config " <> err
|
||||
Right parsedConfig ->
|
||||
@@ -231,8 +234,8 @@ readAppConfig dbSettings optPath prevDbUri roleSettings roleIsolationLvl = do
|
||||
decodeJWKS <$>
|
||||
(decodeSecret =<< readSecretFile =<< readDbUriFile prevDbUri parsedConfig)
|
||||
|
||||
parser :: Maybe FilePath -> Environment -> [(Text, Text)] -> RoleSettings -> RoleIsolationLvl -> C.Parser C.Config AppConfig
|
||||
parser optPath env dbSettings roleSettings roleIsolationLvl =
|
||||
parser :: Maybe FilePath -> Environment -> [(Text, Text)] -> RoleSettings -> RoleIsolationLvl -> ObservationHandler -> C.Parser C.Config AppConfig
|
||||
parser optPath env dbSettings roleSettings roleIsolationLvl observer =
|
||||
AppConfig
|
||||
<$> parseAppSettings "app.settings"
|
||||
<*> (fromMaybe False <$> optBool "db-aggregates-enabled")
|
||||
@@ -285,6 +288,7 @@ parser optPath env dbSettings roleSettings roleIsolationLvl =
|
||||
<*> pure roleSettings
|
||||
<*> pure roleIsolationLvl
|
||||
<*> optInt "internal-schema-cache-sleep"
|
||||
<*> pure observer
|
||||
where
|
||||
parseAppSettings :: C.Key -> C.Parser C.Config [(Text, Text)]
|
||||
parseAppSettings key = addFromEnv . fmap (fmap coerceText) <$> C.subassocs key C.value
|
||||
|
||||
@@ -4,7 +4,7 @@ Description : Wai Middleware to log requests to stdout.
|
||||
-}
|
||||
module PostgREST.Logger
|
||||
( middleware
|
||||
, logObservation
|
||||
, observationLogger
|
||||
, init
|
||||
) where
|
||||
|
||||
@@ -50,8 +50,8 @@ middleware logLevel = case logLevel of
|
||||
& Wai.setApacheUserGetter Auth.getRole
|
||||
}
|
||||
|
||||
logObservation :: LoggerState -> Observation -> IO ()
|
||||
logObservation loggerState obs = logWithZTime loggerState $ observationMessage obs
|
||||
observationLogger :: LoggerState -> ObservationHandler
|
||||
observationLogger loggerState obs = logWithZTime loggerState $ observationMessage obs
|
||||
|
||||
logWithZTime :: LoggerState -> Text -> IO ()
|
||||
logWithZTime loggerState txt = do
|
||||
|
||||
@@ -6,17 +6,17 @@ Description : Module for observability types
|
||||
module PostgREST.Observation
|
||||
( Observation(..)
|
||||
, observationMessage
|
||||
, ObservationHandler
|
||||
) where
|
||||
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as T
|
||||
import qualified Hasql.Connection as SQL
|
||||
import qualified Hasql.Pool as SQL
|
||||
import qualified Network.Socket as NS
|
||||
import Numeric (showFFloat)
|
||||
import qualified PostgREST.Error as Error
|
||||
import PostgREST.SchemaCache (SchemaCache, showSummary)
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as T
|
||||
import qualified Hasql.Connection as SQL
|
||||
import qualified Hasql.Pool as SQL
|
||||
import qualified Network.Socket as NS
|
||||
import Numeric (showFFloat)
|
||||
import qualified PostgREST.Error as Error
|
||||
|
||||
import Protolude
|
||||
import Protolude.Partial (fromJust)
|
||||
@@ -33,7 +33,7 @@ data Observation
|
||||
| SchemaCacheFatalErrorObs SQL.UsageError Text
|
||||
| SchemaCacheNormalErrorObs SQL.UsageError
|
||||
| SchemaCacheQueriedObs Double
|
||||
| SchemaCacheSummaryObs SchemaCache
|
||||
| SchemaCacheSummaryObs Text
|
||||
| SchemaCacheLoadedObs Double
|
||||
| ConnectionRetryObs Int
|
||||
| ConnectionPgVersionErrorObs SQL.UsageError
|
||||
@@ -51,6 +51,8 @@ data Observation
|
||||
| QueryErrorCodeHighObs SQL.UsageError
|
||||
| PoolAcqTimeoutObs SQL.UsageError
|
||||
|
||||
type ObservationHandler = Observation -> IO ()
|
||||
|
||||
observationMessage :: Observation -> Text
|
||||
observationMessage = \case
|
||||
AdminStartObs port ->
|
||||
@@ -75,8 +77,8 @@ observationMessage = \case
|
||||
"An error ocurred when loading the schema cache. " <> jsonMessage usageErr
|
||||
SchemaCacheQueriedObs resultTime ->
|
||||
"Schema cache queried in " <> showMillis resultTime <> " milliseconds"
|
||||
SchemaCacheSummaryObs sCache ->
|
||||
"Schema cache loaded " <> showSummary sCache
|
||||
SchemaCacheSummaryObs summary ->
|
||||
"Schema cache loaded " <> summary
|
||||
SchemaCacheLoadedObs resultTime ->
|
||||
"Schema cache loaded in " <> showMillis resultTime <> " milliseconds"
|
||||
ConnectionRetryObs delay ->
|
||||
|
||||
@@ -43,7 +43,6 @@ import PostgREST.Config (AppConfig (..),
|
||||
import PostgREST.Config.PgVersion (PgVersion (..))
|
||||
import PostgREST.Error (Error)
|
||||
import PostgREST.MediaType (MediaType (..))
|
||||
import PostgREST.Observation (Observation (..))
|
||||
import PostgREST.Plan (ActionPlan (..),
|
||||
CallReadPlan (..),
|
||||
CrudPlan (..),
|
||||
@@ -75,12 +74,12 @@ data QueryResult
|
||||
| NoDbResult InfoPlan
|
||||
|
||||
-- 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 _ _ _ _ (NoDb x) _ _ _ _ = pure $ NoDbResult x
|
||||
runQuery appState config AuthResult{..} apiReq (Db plan) sCache pgVer authenticated observer = do
|
||||
runQuery :: AppState.AppState -> AppConfig -> AuthResult -> ApiRequest -> ActionPlan -> SchemaCache -> PgVersion -> Bool -> ExceptT Error IO QueryResult
|
||||
runQuery _ _ _ _ (NoDb x) _ _ _ = pure $ NoDbResult x
|
||||
runQuery appState config AuthResult{..} apiReq (Db plan) sCache pgVer authenticated = do
|
||||
dbResp <- lift $ do
|
||||
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 <-
|
||||
liftEither . mapLeft Error.PgErr $
|
||||
|
||||
+4
-5
@@ -77,21 +77,20 @@ main = do
|
||||
sockets <- AppState.initSockets testCfg
|
||||
|
||||
let
|
||||
noObs = const $ pure ()
|
||||
-- For tests that run with the same refSchemaCache
|
||||
app config = do
|
||||
appState <- AppState.initWithPool sockets pool config noObs
|
||||
appState <- AppState.initWithPool sockets pool config
|
||||
AppState.putPgVersion appState actualPgVersion
|
||||
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)
|
||||
appDbs config = do
|
||||
customSchemaCache <- loadSCache pool config
|
||||
appState <- AppState.initWithPool sockets pool config noObs
|
||||
appState <- AppState.initWithPool sockets pool config
|
||||
AppState.putPgVersion appState actualPgVersion
|
||||
AppState.putSchemaCache appState (Just customSchemaCache)
|
||||
return ((), postgrest (configLogLevel config) appState (pure ()) noObs)
|
||||
return ((), postgrest (configLogLevel config) appState (pure ()))
|
||||
|
||||
let withApp = app testCfg
|
||||
maxRowsApp = app testMaxRowsCfg
|
||||
|
||||
@@ -141,6 +141,7 @@ baseCfg = let secret = Just $ encodeUtf8 "reallyreallyreallyreallyverysafe" in
|
||||
, configRoleIsoLvl = mempty
|
||||
, configInternalSCSleep = Nothing
|
||||
, configServerTimingEnabled = True
|
||||
, configObserver = const $ pure ()
|
||||
}
|
||||
|
||||
testCfg :: AppConfig
|
||||
|
||||
Reference in New Issue
Block a user