From 69c6ce9c38074e5a152c222ce1d14d60647e99ed Mon Sep 17 00:00:00 2001 From: steve-chavez Date: Sun, 14 Apr 2024 14:15:50 -0500 Subject: [PATCH] refactor: use LogLevel in Logger * remove Logger dependency on Auth. --- src/PostgREST/Admin.hs | 5 +-- src/PostgREST/App.hs | 5 +-- src/PostgREST/AppState.hs | 74 +++++++++++++++++++++++---------------- src/PostgREST/CLI.hs | 7 ++-- src/PostgREST/Config.hs | 14 +++----- src/PostgREST/Logger.hs | 26 ++++++++------ src/PostgREST/Query.hs | 2 +- test/spec/Main.hs | 7 ++-- test/spec/SpecHelper.hs | 1 - 9 files changed, 77 insertions(+), 64 deletions(-) diff --git a/src/PostgREST/Admin.hs b/src/PostgREST/Admin.hs index af1902e851..e46d02bd85 100644 --- a/src/PostgREST/Admin.hs +++ b/src/PostgREST/Admin.hs @@ -27,12 +27,13 @@ import qualified PostgREST.Config as Config import Protolude runAdmin :: AppConfig -> AppState -> Warp.Settings -> IO () -runAdmin conf@AppConfig{configAdminServerPort, configObserver=observer} appState settings = +runAdmin conf@AppConfig{configAdminServerPort} appState settings = whenJust (AppState.getSocketAdmin appState) $ \adminSocket -> do observer $ AdminStartObs configAdminServerPort void . forkIO $ Warp.runSettingsSocket settings adminSocket adminApp where adminApp = admin appState conf + observer = AppState.getObserver appState -- | PostgREST admin application admin :: AppState.AppState -> AppConfig -> Wai.Application @@ -42,7 +43,7 @@ admin appState appConfig req respond = do isConnectionUp <- if configDbChannelEnabled appConfig then AppState.getIsListenerOn appState - else isRight <$> AppState.usePool appState appConfig (SQL.sql "SELECT 1") + else isRight <$> AppState.usePool appState (SQL.sql "SELECT 1") case Wai.pathInfo req of ["ready"] -> diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index a10be5e050..06a2055610 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -62,7 +62,8 @@ type Handler = ExceptT Error run :: AppState -> IO () run appState = do - conf@AppConfig{configObserver=observer, ..} <- AppState.getConfig appState + let observer = AppState.getObserver appState + conf@AppConfig{..} <- AppState.getConfig appState observer $ AppServerStartObs prettyVersion @@ -97,7 +98,7 @@ postgrest logLevel appState connWorker = traceHeaderMiddleware appState . Cors.middleware appState . Auth.middleware appState . - Logger.middleware logLevel $ + Logger.middleware logLevel Auth.getRole $ -- fromJust can be used, because the auth middleware will **always** add -- some AuthResult to the vault. \req respond -> case fromJust $ Auth.getResult req of diff --git a/src/PostgREST/AppState.hs b/src/PostgREST/AppState.hs index 088cc5c8cf..cbea46e40e 100644 --- a/src/PostgREST/AppState.hs +++ b/src/PostgREST/AppState.hs @@ -27,6 +27,7 @@ module PostgREST.AppState , reReadConfig , connectionWorker , runListener + , getObserver ) where import qualified Data.Aeson as JSON @@ -43,6 +44,7 @@ import qualified Hasql.Transaction.Sessions as SQL import qualified Network.HTTP.Types.Status as HTTP import qualified Network.Socket as NS import qualified PostgREST.Error as Error +import qualified PostgREST.Logger as Logger import PostgREST.Observation import PostgREST.Version (prettyVersion) import System.TimeIt (timeItT) @@ -57,7 +59,6 @@ import Data.IORef (IORef, atomicWriteIORef, newIORef, import Data.Time.Clock (UTCTime, getCurrentTime) import PostgREST.Config (AppConfig (..), - LogLevel (..), addFallbackAppName, readAppConfig) import PostgREST.Config.Database (queryDbSettings, @@ -109,19 +110,26 @@ data AppState = AppState , stateSocketREST :: NS.Socket -- | Network socket for the admin UI , stateSocketAdmin :: Maybe NS.Socket + -- | Logger state + , stateLogger :: Logger.LoggerState + -- | Observation handler + , stateObserver :: ObservationHandler } type AppSockets = (NS.Socket, Maybe NS.Socket) init :: AppConfig -> IO AppState -init conf = do +init conf@AppConfig{configLogLevel} = do + loggerState <- Logger.init + let observer = Logger.observationLogger loggerState configLogLevel pool <- initPool conf (sock, adminSock) <- initSockets conf - state' <- initWithPool (sock, adminSock) pool conf - pure state' { stateSocketREST = sock, stateSocketAdmin = adminSock } + state' <- initWithPool (sock, adminSock) pool conf loggerState observer + pure state' { stateSocketREST = sock, stateSocketAdmin = adminSock} + +initWithPool :: AppSockets -> SQL.Pool -> AppConfig -> Logger.LoggerState -> ObservationHandler -> IO AppState +initWithPool (sock, adminSock) pool conf loggerState observer = do -initWithPool :: AppSockets -> SQL.Pool -> AppConfig -> IO AppState -initWithPool (sock, adminSock) 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 @@ -136,6 +144,8 @@ initWithPool (sock, adminSock) pool conf = do <*> C.newCache Nothing <*> pure sock <*> pure adminSock + <*> pure loggerState + <*> pure observer debWorker <- let decisecond = 100000 in @@ -193,17 +203,16 @@ initPool AppConfig{..} = (toUtf8 $ addFallbackAppName prettyVersion configDbUri) -- | Run an action with a database connection. -usePool :: AppState -> AppConfig -> SQL.Session a -> IO (Either SQL.UsageError a) -usePool AppState{..} AppConfig{configLogLevel, configObserver=observer} sess = do +usePool :: AppState -> SQL.Session a -> IO (Either SQL.UsageError a) +usePool AppState{stateObserver=observer,..} sess = do res <- SQL.use statePool sess - when (configLogLevel > LogCrit) $ do - whenLeft res (\case - SQL.AcquisitionTimeoutUsageError -> observer $ PoolAcqTimeoutObs SQL.AcquisitionTimeoutUsageError - error - -- TODO We're using the 500 HTTP status for getting all internal db errors but there's no response here. We need a new intermediate type to not rely on the HTTP status. - | Error.status (Error.PgError False error) >= HTTP.status500 -> observer $ QueryErrorCodeHighObs error - | otherwise -> pure ()) + whenLeft res (\case + SQL.AcquisitionTimeoutUsageError -> observer $ PoolAcqTimeoutObs SQL.AcquisitionTimeoutUsageError + error + -- TODO We're using the 500 HTTP status for getting all internal db errors but there's no response here. We need a new intermediate type to not rely on the HTTP status. + | Error.status (Error.PgError False error) >= HTTP.status500 -> observer $ QueryErrorCodeHighObs error + | otherwise -> pure ()) return res @@ -281,6 +290,9 @@ getSchemaCacheLoaded = readIORef . stateSchemaCacheLoaded putSchemaCacheLoaded :: AppState -> Bool -> IO () putSchemaCacheLoaded = atomicWriteIORef . stateSchemaCacheLoaded +getObserver :: AppState -> ObservationHandler +getObserver = stateObserver + -- | Schema cache status data SCacheStatus = SCLoaded @@ -288,12 +300,12 @@ data SCacheStatus | SCFatalFail -- | Load the SchemaCache by using a connection from the pool. -loadSchemaCache :: AppState -> AppConfig -> IO SCacheStatus -loadSchemaCache appState AppConfig{configObserver=observer} = do +loadSchemaCache :: AppState -> IO SCacheStatus +loadSchemaCache appState@AppState{stateObserver=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) + timeItT $ usePool appState (transaction SQL.ReadCommitted SQL.Read $ querySchemaCache conf) case result of Left e -> do case checkIsFatal e of @@ -333,12 +345,12 @@ data ConnectionStatus -- program. -- 3. Obtains the sCache. If this fails, it goes back to 1. internalConnectionWorker :: AppState -> IO () -internalConnectionWorker appState = work +internalConnectionWorker appState@AppState{stateObserver=observer} = work where work = do - config@AppConfig{configObserver=observer, ..} <- getConfig appState + AppConfig{..} <- getConfig appState observer DBConnectAttemptObs - connected <- establishConnection appState config + connected <- establishConnection appState case connected of FatalConnectionError reason -> -- Fatal error when connecting @@ -356,7 +368,7 @@ internalConnectionWorker appState = work -- 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 config + scStatus <- loadSchemaCache appState case scStatus of SCLoaded -> -- do nothing and proceed if the load was successful @@ -378,8 +390,8 @@ internalConnectionWorker appState = work -- -- The connection tries are capped, but if the connection times out no error is -- thrown, just 'False' is returned. -establishConnection :: AppState -> AppConfig -> IO ConnectionStatus -establishConnection appState config@AppConfig{configObserver=observer} = +establishConnection :: AppState -> IO ConnectionStatus +establishConnection appState@AppState{stateObserver=observer} = retrying retrySettings shouldRetry $ const $ flushPool appState >> getConnectionStatus where @@ -389,7 +401,7 @@ establishConnection appState config@AppConfig{configObserver=observer} = getConnectionStatus :: IO ConnectionStatus getConnectionStatus = do - pgVersion <- usePool appState config (queryPgVersion False) -- No need to prepare the query here, as the connection might not be established + 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 observer $ ConnectionPgVersionErrorObs e @@ -418,12 +430,12 @@ establishConnection appState config@AppConfig{configObserver=observer} = -- | Re-reads the config plus config options from the db reReadConfig :: Bool -> AppState -> IO () -reReadConfig startingUp appState = do - config@AppConfig{configObserver=observer, ..} <- getConfig appState +reReadConfig startingUp appState@AppState{stateObserver=observer} = do + AppConfig{..} <- getConfig appState pgVer <- getPgVersion appState dbSettings <- if configDbConfig then do - qDbSettings <- usePool appState config (queryDbSettings (dumpQi <$> configDbPreConfig) configDbPreparedStatements) + qDbSettings <- usePool appState (queryDbSettings (dumpQi <$> configDbPreConfig) configDbPreparedStatements) case qDbSettings of Left e -> do observer ConfigReadErrorObs @@ -439,7 +451,7 @@ reReadConfig startingUp appState = do pure mempty (roleSettings, roleIsolationLvl) <- if configDbConfig then do - rSettings <- usePool appState config (queryRoleSettings pgVer configDbPreparedStatements) + rSettings <- usePool appState (queryRoleSettings pgVer configDbPreparedStatements) case rSettings of Left e -> do observer $ QueryRoleSettingsErrorObs e @@ -447,7 +459,7 @@ reReadConfig startingUp appState = do Right x -> pure x else pure mempty - readAppConfig dbSettings configFilePath (Just configDbUri) roleSettings roleIsolationLvl observer >>= \case + readAppConfig dbSettings configFilePath (Just configDbUri) roleSettings roleIsolationLvl >>= \case Left err -> if startingUp then panic err -- die on invalid config if the program is starting up @@ -468,7 +480,7 @@ runListener conf@AppConfig{configDbChannelEnabled} appState = do -- NOTIFY - with an empty payload - is done, it refills the schema -- cache. It uses the connectionWorker in case the LISTEN connection dies. listener :: AppState -> AppConfig -> IO () -listener appState conf@AppConfig{configObserver=observer, ..} = do +listener appState@AppState{stateObserver=observer} conf@AppConfig{..} = do let dbChannel = toS configDbChannel -- The listener has to wait for a signal from the connectionWorker. diff --git a/src/PostgREST/CLI.hs b/src/PostgREST/CLI.hs index 68ef441d8b..bf33509a28 100644 --- a/src/PostgREST/CLI.hs +++ b/src/PostgREST/CLI.hs @@ -25,17 +25,14 @@ import PostgREST.Version (prettyVersion) import qualified PostgREST.App as App import qualified PostgREST.AppState as AppState import qualified PostgREST.Config as Config -import qualified PostgREST.Logger as Logger import Protolude hiding (hPutStrLn) main :: CLI -> IO () main CLI{cliCommand, cliPath} = do - loggerState <- Logger.init - conf@AppConfig{..} <- - either panic identity <$> Config.readAppConfig mempty cliPath Nothing mempty mempty (Logger.observationLogger loggerState) + either panic identity <$> Config.readAppConfig mempty cliPath Nothing mempty mempty -- Per https://github.com/PostgREST/postgrest/issues/268, we want to -- explicitly close the connections to PostgreSQL on shutdown. @@ -56,7 +53,7 @@ dumpSchema appState = do conf@AppConfig{..} <- AppState.getConfig appState result <- let transaction = if configDbPreparedStatements then SQL.transaction else SQL.unpreparedTransaction in - AppState.usePool appState conf + AppState.usePool appState (transaction SQL.ReadCommitted SQL.Read $ querySchemaCache conf) case result of Left e -> do diff --git a/src/PostgREST/Config.hs b/src/PostgREST/Config.hs index f8d1f7062f..6d4de526da 100644 --- a/src/PostgREST/Config.hs +++ b/src/PostgREST/Config.hs @@ -64,8 +64,6 @@ import PostgREST.Config.Proxy (Proxy (..), import PostgREST.SchemaCache.Identifiers (QualifiedIdentifier, dumpQi, toQi) -import PostgREST.Observation - import Protolude hiding (Proxy, toList) @@ -114,7 +112,6 @@ data AppConfig = AppConfig , configRoleSettings :: RoleSettings , configRoleIsoLvl :: RoleIsolationLvl , configInternalSCSleep :: Maybe Int32 - , configObserver :: ObservationHandler } data LogLevel = LogCrit | LogError | LogWarn | LogInfo @@ -213,13 +210,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 -> ObservationHandler -> IO (Either Text AppConfig) -readAppConfig dbSettings optPath prevDbUri roleSettings roleIsolationLvl observer = do +readAppConfig :: [(Text, Text)] -> Maybe FilePath -> Maybe Text -> RoleSettings -> RoleIsolationLvl -> IO (Either Text AppConfig) +readAppConfig dbSettings optPath prevDbUri roleSettings roleIsolationLvl = 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 observer) =<< mapLeft show conf of + case C.runParser (parser optPath env dbSettings roleSettings roleIsolationLvl) =<< mapLeft show conf of Left err -> return . Left $ "Error in config " <> err Right parsedConfig -> @@ -234,8 +231,8 @@ readAppConfig dbSettings optPath prevDbUri roleSettings roleIsolationLvl observe decodeJWKS <$> (decodeSecret =<< readSecretFile =<< readDbUriFile prevDbUri parsedConfig) -parser :: Maybe FilePath -> Environment -> [(Text, Text)] -> RoleSettings -> RoleIsolationLvl -> ObservationHandler -> C.Parser C.Config AppConfig -parser optPath env dbSettings roleSettings roleIsolationLvl observer = +parser :: Maybe FilePath -> Environment -> [(Text, Text)] -> RoleSettings -> RoleIsolationLvl -> C.Parser C.Config AppConfig +parser optPath env dbSettings roleSettings roleIsolationLvl = AppConfig <$> parseAppSettings "app.settings" <*> (fromMaybe False <$> optBool "db-aggregates-enabled") @@ -288,7 +285,6 @@ parser optPath env dbSettings roleSettings roleIsolationLvl observer = <*> 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 diff --git a/src/PostgREST/Logger.hs b/src/PostgREST/Logger.hs index 1a279ea968..dcee2d0ec0 100644 --- a/src/PostgREST/Logger.hs +++ b/src/PostgREST/Logger.hs @@ -6,11 +6,13 @@ module PostgREST.Logger ( middleware , observationLogger , init + , LoggerState ) where -import Control.AutoUpdate (defaultUpdateSettings, mkAutoUpdate, - updateAction) -import Control.Debounce +import Control.AutoUpdate (defaultUpdateSettings, + mkAutoUpdate, updateAction) +import Control.Debounce +import qualified Data.ByteString.Char8 as BS import Data.Time (ZonedTime, defaultTimeLocale, formatTime, getZonedTime) @@ -24,8 +26,6 @@ import System.IO.Unsafe (unsafePerformIO) import PostgREST.Config (LogLevel (..)) import PostgREST.Observation -import qualified PostgREST.Auth as Auth - import Protolude data LoggerState = LoggerState @@ -54,8 +54,8 @@ logWithDebounce loggerState action = do putMVar (stateLogDebouncePoolTimeout loggerState) newDebouncer newDebouncer -middleware :: LogLevel -> Wai.Middleware -middleware logLevel = case logLevel of +middleware :: LogLevel -> (Wai.Request -> Maybe BS.ByteString) -> Wai.Middleware +middleware logLevel getAuthRole = case logLevel of LogInfo -> requestLogger (const True) LogWarn -> requestLogger (>= status400) LogError -> requestLogger (>= status500) @@ -67,15 +67,19 @@ middleware logLevel = case logLevel of Wai.ApacheWithSettings $ Wai.defaultApacheSettings & Wai.setApacheRequestFilter (\_ res -> filterStatus $ Wai.responseStatus res) & - Wai.setApacheUserGetter Auth.getRole + Wai.setApacheUserGetter getAuthRole , Wai.autoFlush = True , Wai.destination = Wai.Handle stdout } -observationLogger :: LoggerState -> ObservationHandler -observationLogger loggerState obs = case obs of +observationLogger :: LoggerState -> LogLevel -> ObservationHandler +observationLogger loggerState logLevel obs = case obs of o@(PoolAcqTimeoutObs _) -> do - logWithDebounce loggerState $ + when (logLevel >= LogError) $ do + logWithDebounce loggerState $ + logWithZTime loggerState $ observationMessage o + o@(QueryErrorCodeHighObs _) -> do + when (logLevel >= LogError) $ do logWithZTime loggerState $ observationMessage o o -> logWithZTime loggerState $ observationMessage o diff --git a/src/PostgREST/Query.hs b/src/PostgREST/Query.hs index 7a1b319fd7..7332f7b417 100644 --- a/src/PostgREST/Query.hs +++ b/src/PostgREST/Query.hs @@ -79,7 +79,7 @@ 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) + AppState.usePool appState (transaction isoLvl txMode $ runExceptT dbHandler) resp <- liftEither . mapLeft Error.PgErr $ diff --git a/test/spec/Main.hs b/test/spec/Main.hs index b4ab6389c7..044fe0b1b3 100644 --- a/test/spec/Main.hs +++ b/test/spec/Main.hs @@ -15,6 +15,7 @@ import Protolude hiding (toList, toS) import SpecHelper import qualified PostgREST.AppState as AppState +import qualified PostgREST.Logger as Logger import qualified Feature.Auth.AsymmetricJwtSpec import qualified Feature.Auth.AudienceJwtSecretSpec @@ -68,6 +69,7 @@ import qualified Feature.RpcPreRequestGucsSpec main :: IO () main = do + let observer = const $ pure () pool <- P.acquire 3 10 60 60 $ toUtf8 $ configDbUri testCfg actualPgVersion <- either (panic . show) id <$> P.use pool (queryPgVersion False) @@ -75,11 +77,12 @@ main = do -- cached schema cache so most tests run fast baseSchemaCache <- loadSCache pool testCfg sockets <- AppState.initSockets testCfg + loggerState <- Logger.init let -- For tests that run with the same refSchemaCache app config = do - appState <- AppState.initWithPool sockets pool config + appState <- AppState.initWithPool sockets pool config loggerState observer AppState.putPgVersion appState actualPgVersion AppState.putSchemaCache appState (Just baseSchemaCache) return ((), postgrest (configLogLevel config) appState (pure ())) @@ -87,7 +90,7 @@ main = do -- For tests that run with a different SchemaCache(depends on configSchemas) appDbs config = do customSchemaCache <- loadSCache pool config - appState <- AppState.initWithPool sockets pool config + appState <- AppState.initWithPool sockets pool config loggerState observer AppState.putPgVersion appState actualPgVersion AppState.putSchemaCache appState (Just customSchemaCache) return ((), postgrest (configLogLevel config) appState (pure ())) diff --git a/test/spec/SpecHelper.hs b/test/spec/SpecHelper.hs index e3aa82ee87..362c61f4c0 100644 --- a/test/spec/SpecHelper.hs +++ b/test/spec/SpecHelper.hs @@ -154,7 +154,6 @@ baseCfg = let secret = Just $ encodeUtf8 "reallyreallyreallyreallyverysafe" in , configRoleIsoLvl = mempty , configInternalSCSleep = Nothing , configServerTimingEnabled = True - , configObserver = const $ pure () } testCfg :: AppConfig