refactor: use LogLevel in Logger

* remove Logger dependency on Auth.

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"] ->

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

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
+  state' <- initWithPool (sock, adminSock) pool conf loggerState observer
-  pure state' { stateSocketREST = sock, stateSocketAdmin = adminSock }
+  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 -> SQL.Session a -> IO (Either SQL.UsageError a)
-usePool AppState{..} AppConfig{configLogLevel, configObserver=observer} sess = do
+usePool AppState{stateObserver=observer,..} sess = do
   res <- SQL.use statePool sess
 
-  when (configLogLevel > LogCrit) $ do
+  whenLeft res (\case
-    whenLeft res (\case
+    SQL.AcquisitionTimeoutUsageError -> observer $ PoolAcqTimeoutObs SQL.AcquisitionTimeoutUsageError
-      SQL.AcquisitionTimeoutUsageError -> observer $ PoolAcqTimeoutObs SQL.AcquisitionTimeoutUsageError
+    error
-      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.
-        -- 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
-        | Error.status (Error.PgError False error) >= HTTP.status500 -> observer $ QueryErrorCodeHighObs error
+      | otherwise -> pure ())
-        | 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 -> IO SCacheStatus
-loadSchemaCache appState AppConfig{configObserver=observer} = do
+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 -> IO ConnectionStatus
-establishConnection appState config@AppConfig{configObserver=observer} =
+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
+reReadConfig startingUp appState@AppState{stateObserver=observer} = do
-  config@AppConfig{configObserver=observer, ..} <- getConfig appState
+  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 <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 -> 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.

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

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 :: [(Text, Text)] -> Maybe FilePath -> Maybe Text -> RoleSettings -> RoleIsolationLvl -> IO (Either Text AppConfig)
-readAppConfig dbSettings optPath prevDbUri roleSettings roleIsolationLvl observer = do
+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 :: Maybe FilePath -> Environment -> [(Text, Text)] -> RoleSettings -> RoleIsolationLvl -> C.Parser C.Config AppConfig
-parser optPath env dbSettings roleSettings roleIsolationLvl observer =
+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

src/PostgREST/Logger.hs

@@ -6,11 +6,13 @@ module PostgREST.Logger
   ( middleware
   , observationLogger
   , init
+  , LoggerState
   ) where
 
-import Control.AutoUpdate (defaultUpdateSettings, mkAutoUpdate,
+import           Control.AutoUpdate    (defaultUpdateSettings,
-                           updateAction)
+                                        mkAutoUpdate, updateAction)
-import Control.Debounce
+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 -> (Wai.Request -> Maybe BS.ByteString) -> Wai.Middleware
-middleware logLevel = case logLevel of
+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 -> LogLevel -> ObservationHandler
-observationLogger loggerState obs = case obs of
+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

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 $

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 ()))

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