add: make config log-level reloadable

Closes #5113.

Signed-off-by: Taimoor Zaeem <taimoorzaeem@gmail.com>

src/library/PostgREST/AppState.hs

@@ -39,7 +39,7 @@ import           PostgREST.Version       (prettyVersion)
 import Control.AutoUpdate         (defaultUpdateSettings, mkAutoUpdate,
                                    updateAction)
 import Control.Concurrent.STM     (newEmptyTMVarIO)
-import Data.IORef                 (newIORef, readIORef)
+import Data.IORef                 (IORef, newIORef, readIORef)
 import Data.Time.Clock            (getCurrentTime)
 import PostgREST.AppState.Pool    (destroy, initPool, usePool)
 import PostgREST.AppState.Reload  (isSchemaCacheLoaded, readInDbConfig,
@@ -54,26 +54,29 @@ import PostgREST.Debounce         (makeDebouncer)
 import Protolude
 
 init :: AppConfig -> IO () -> IO AppState
-init conf@AppConfig{configLogLevel, configDbPoolSize} appKiller = do
-  loggerState  <- Logger.init
+init conf@AppConfig{configDbPoolSize} appKiller = do
+  -- We need to create IORef first, so we can make its read action part of
+  -- loggerState. This is needed for log-level config reloading.
+  confRef <- newIORef conf
+  loggerState  <- Logger.init (configLogLevel <$> readIORef confRef)
   metricsState <- Metrics.init configDbPoolSize
-  let observer = liftA2 (>>) (Logger.observationLogger loggerState configLogLevel) (Metrics.observationMetrics metricsState)
+  let observer = liftA2 (>>) (Logger.observationLogger loggerState) (Metrics.observationMetrics metricsState)
 
   observer $ AppStartObs prettyVersion
 
   pool <- initPool conf observer
-  initWithPool pool conf loggerState metricsState observer appKiller
-
-initWithPool :: SQL.Pool -> AppConfig -> Logger.LoggerState -> Metrics.MetricsState -> ObservationHandler -> IO () -> IO AppState
-initWithPool pool conf loggerState metricsState observer appKiller = mdo
+  initWithPool pool confRef loggerState metricsState observer appKiller
 
+initWithPool :: SQL.Pool -> IORef AppConfig -> Logger.LoggerState -> Metrics.MetricsState -> ObservationHandler -> IO () -> IO AppState
+initWithPool pool confRef loggerState metricsState observer appKiller = mdo
+  conf <- readIORef confRef
   appState <- AppState pool
     <$> newIORef minimumPgVersion -- assume we're in a supported version when starting, this will be corrected on a later step
     <*> newIORef Nothing
     <*> newSchemaCacheStatus
     <*> newIORef False
     <*> makeDebouncer (retryingSchemaCacheLoad appState *> threadDelay 100000)  -- 100ms cooldown
-    <*> newIORef conf
+    <*> pure confRef
     <*> mkAutoUpdate defaultUpdateSettings { updateAction = getCurrentTime }
     <*> pure appKiller
     <*> newIORef 0

src/library/PostgREST/Logger.hs

@@ -45,13 +45,14 @@ import           Protolude
 data LoggerState = LoggerState
   { stateGetZTime               :: IO ZonedTime  -- ^ Time with time zone used for logs
   , stateLogDebouncePoolTimeout :: IO ()         -- ^ Logs with a debounce
+  , getLogLevel                 :: IO LogLevel   -- ^ Get LogLevel from Config
   }
 
-init :: IO LoggerState
-init = mdo
+init :: IO LogLevel -> IO LoggerState
+init getLogLvl = mdo
   let
     oneSecond = 1_000_000
-    loggerState = LoggerState zTime debouncePoolTimeout
+    loggerState = LoggerState zTime debouncePoolTimeout getLogLvl
   zTime <- mkAutoUpdate defaultUpdateSettings { updateAction = getZonedTime }
   debouncePoolTimeout <- makeDebouncer $
     logWithZTime loggerState (observationMessages PoolAcqTimeoutObs) *> threadDelay (5 * oneSecond)
@@ -66,47 +67,49 @@ shouldLogResponse logLevel = case logLevel of
   LogDebug -> const True
 
 -- All observations are logged except some that depend on the log-level
-observationLogger :: LoggerState -> LogLevel -> ObservationHandler
-observationLogger loggerState logLevel obs = case obs of
-  PoolAcqTimeoutObs -> do
-    when (logLevel >= LogError) $
-      stateLogDebouncePoolTimeout loggerState
-  o@(QueryErrorCodeHighObs _) -> do
-    when (logLevel >= LogError) $ do
+observationLogger :: LoggerState -> ObservationHandler
+observationLogger loggerState obs = do
+  logLevel <- getLogLevel loggerState -- We need to do the IO action to read the "log-level" config value because it can be reloaded
+  case obs of
+    PoolAcqTimeoutObs -> do
+      when (logLevel >= LogError) $
+        stateLogDebouncePoolTimeout loggerState
+    o@(QueryErrorCodeHighObs _) -> do
+      when (logLevel >= LogError) $ do
+        logWithZTime loggerState $ observationMessages o
+    o@SchemaCacheEmptyObs ->
+      when (logLevel >= LogError) $ do
       logWithZTime loggerState $ observationMessages o
-  o@SchemaCacheEmptyObs ->
-    when (logLevel >= LogError) $ do
-    logWithZTime loggerState $ observationMessages o
-  o@(HasqlPoolObs _) -> do
-    when (logLevel >= LogDebug) $ do
+    o@(HasqlPoolObs _) -> do
+      when (logLevel >= LogDebug) $ do
+        logWithZTime loggerState $ observationMessages o
+    o@(QueryObs _ status) -> do
+      when (shouldLogResponse logLevel status) $
+        logWithZTime loggerState $ observationMessages o
+    o@PoolRequest ->
+      when (logLevel >= LogDebug) $ do
+        logWithZTime loggerState $ observationMessages o
+    o@PoolRequestFullfilled ->
+      when (logLevel >= LogDebug) $ do
+        logWithZTime loggerState $ observationMessages o
+    ResponseObs maybeRole req status contentLen ->
+      when (shouldLogResponse logLevel status) $ do
+        zTime <- stateGetZTime loggerState
+        putStr $ apacheFormat maybeRole (BS.pack $ formatZonedTime zTime) req status contentLen -- putStr prints to stdout
+    o@PoolFlushed ->
+      when (logLevel >= LogDebug) $ do
+        logWithZTime loggerState $ observationMessages o
+    o@JwtCacheEviction ->
+      when (logLevel >= LogDebug) $ do
+        logWithZTime loggerState $ observationMessages o
+    o@(JwtCacheLookup _) ->
+      when (logLevel >= LogDebug) $ do
+        logWithZTime loggerState $ observationMessages o
+    o@(WarpServerObs _) ->
+      when (logLevel >= LogDebug) $ do
+        logWithZTime loggerState $ observationMessages o
+    o ->
       logWithZTime loggerState $ observationMessages o
-  o@(QueryObs _ status) -> do
-    when (shouldLogResponse logLevel status) $
-      logWithZTime loggerState $ observationMessages o
-  o@PoolRequest ->
-    when (logLevel >= LogDebug) $ do
-      logWithZTime loggerState $ observationMessages o
-  o@PoolRequestFullfilled ->
-    when (logLevel >= LogDebug) $ do
-      logWithZTime loggerState $ observationMessages o
-  ResponseObs maybeRole req status contentLen ->
-    when (shouldLogResponse logLevel status) $ do
-      zTime <- stateGetZTime loggerState
-      putStr $ apacheFormat maybeRole (BS.pack $ formatZonedTime zTime) req status contentLen -- putStr prints to stdout
-  o@PoolFlushed ->
-    when (logLevel >= LogDebug) $ do
-      logWithZTime loggerState $ observationMessages o
-  o@JwtCacheEviction ->
-    when (logLevel >= LogDebug) $ do
-      logWithZTime loggerState $ observationMessages o
-  o@(JwtCacheLookup _) ->
-    when (logLevel >= LogDebug) $ do
-      logWithZTime loggerState $ observationMessages o
-  o@(WarpServerObs _) ->
-    when (logLevel >= LogDebug) $ do
-      logWithZTime loggerState $ observationMessages o
-  o ->
-    logWithZTime loggerState $ observationMessages o
 
 logWithZTime :: LoggerState -> [Text] -> IO ()
 logWithZTime loggerState txts = do