refactor: make observation messages pure (#3250)

removes the observation messages from the Logger

src/PostgREST/App.hs

@@ -69,7 +69,7 @@ type Handler = ExceptT Error
 
 run :: AppState -> (Observation -> IO ()) -> IO ()
 run appState observer = do
-  observer $ AppStartObs prettyVersion
+  observer $ AppServerStartObs prettyVersion
 
   conf@AppConfig{..} <- AppState.getConfig appState
   AppState.connectionWorker appState -- Loads the initial SchemaCache

src/PostgREST/AppState.hs

@@ -300,16 +300,17 @@ loadSchemaCache appState observer = do
     Left e -> do
       case checkIsFatal e of
         Just hint -> do
-          observer $ AppSCacheFatalErrorObs e hint
+          observer $ SchemaCacheFatalErrorObs e hint
           return SCFatalFail
         Nothing -> do
           putSchemaCache appState Nothing
-          observer $ AppSCacheNormalErrorObs e
+          observer $ SchemaCacheNormalErrorObs e
           return SCOnRetry
 
     Right sCache -> do
       putSchemaCache appState $ Just sCache
-      observer $ AppSCacheLoadSuccessObs sCache resultTime
+      observer $ SchemaCacheQueriedObs resultTime
+      observer $ SchemaCacheLoadedObs sCache
       return SCLoaded
 
 -- | Current database connection status data ConnectionStatus
@@ -335,22 +336,22 @@ internalConnectionWorker appState observer = work
   where
     work = do
       config@AppConfig{..} <- getConfig appState
-      observer AppDBConnectAttemptObs
+      observer DBConnectAttemptObs
       connected <- establishConnection appState config observer
       case connected of
         FatalConnectionError reason ->
           -- Fatal error when connecting
-          observer (AppExitFatalObs reason) >> killThread (getMainThreadId appState)
+          observer (ExitFatalObs reason) >> killThread (getMainThreadId appState)
         NotConnected ->
           -- Unreachable because establishConnection will keep trying to connect, unless disable-recovery is turned on
           unless configDbPoolAutomaticRecovery
-              $ observer AppExitDBNoRecoveryObs >> killThread (getMainThreadId appState)
+              $ observer ExitDBNoRecoveryObs >> killThread (getMainThreadId appState)
         Connected actualPgVersion -> do
           -- Procede with initialization
           putPgVersion appState actualPgVersion
           when configDbChannelEnabled $
             signalListener appState
-          observer (AppDBConnectedObs $ pgvFullName actualPgVersion)
+          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
@@ -523,16 +524,16 @@ checkIsFatal(SQL.SessionUsageError (SQL.QueryError _ _ (SQL.ResultError serverEr
   = case serverError of
       -- Check for a syntax error (42601 is the pg code). This would mean the error is on our part somehow, so we treat it as fatal.
       SQL.ServerError "42601" _ _ _ _
-        -> Just "Hint: This is probably a bug in PostgREST, please report it at https://github.com/PostgREST/postgrest/issues"
+        -> Just "This is probably a bug in PostgREST, please report it at https://github.com/PostgREST/postgrest/issues"
       -- Check for a "prepared statement <name> already exists" error (Code 42P05: duplicate_prepared_statement).
       -- This would mean that a connection pooler in transaction mode is being used
       -- while prepared statements are enabled in the PostgREST configuration,
       -- both of which are incompatible with each other.
       SQL.ServerError "42P05" _ _ _ _
-        -> Just "Hint: If you are using connection poolers in transaction mode, try setting db-prepared-statements to false."
+        -> Just "If you are using connection poolers in transaction mode, try setting db-prepared-statements to false."
       -- Check for a "transaction blocks not allowed in statement pooling mode" error (Code 08P01: protocol_violation).
       -- This would mean that a connection pooler in statement mode is being used which is not supported in PostgREST.
       SQL.ServerError "08P01" "transaction blocks not allowed in statement pooling mode" _ _ _
-        -> Just "Hint: Connection poolers in statement mode are not supported."
+        -> Just "Connection poolers in statement mode are not supported."
       _ -> Nothing
 checkIsFatal _ = Nothing

src/PostgREST/Logger.hs

@@ -11,16 +11,11 @@ module PostgREST.Logger
 import Control.AutoUpdate (defaultUpdateSettings, mkAutoUpdate,
                            updateAction)
 
-import qualified Data.ByteString.Lazy as LBS
+import Data.Time (ZonedTime, defaultTimeLocale, formatTime,
-import qualified Data.Text.Encoding   as T
+                  getZonedTime)
-import           Data.Time            (ZonedTime, defaultTimeLocale,
-                                       formatTime, getZonedTime)
-import qualified Hasql.Pool           as SQL
 
 import qualified Network.Wai                          as Wai
 import qualified Network.Wai.Middleware.RequestLogger as Wai
-import           Numeric                              (showFFloat)
-
 
 import Network.HTTP.Types.Status (status400, status500)
 import System.IO.Unsafe          (unsafePerformIO)
@@ -29,13 +24,8 @@ import PostgREST.Config      (LogLevel (..))
 import PostgREST.Observation
 
 import qualified PostgREST.Auth as Auth
-import qualified PostgREST.Error as Error
-
-import PostgREST.SchemaCache (showSummary)
-
 
 import Protolude
-import Protolude.Partial (fromJust)
 
 newtype LoggerState = LoggerState
   { stateGetZTime                 :: IO ZonedTime -- ^ Time with time zone used for logs
@@ -46,14 +36,6 @@ init = do
   zTime <- mkAutoUpdate defaultUpdateSettings { updateAction = getZonedTime }
   pure $ LoggerState zTime
 
-logWithZTime :: LoggerState -> Text -> IO ()
-logWithZTime loggerState txt = do
-  zTime <- stateGetZTime loggerState
-  hPutStrLn stderr $ toS (formatTime defaultTimeLocale "%d/%b/%Y:%T %z: " zTime) <> txt
-
-logPgrstError :: LoggerState -> SQL.UsageError -> IO ()
-logPgrstError loggerState e = logWithZTime loggerState . T.decodeUtf8 . LBS.toStrict $ Error.errorPayload $ Error.PgError False e
-
 middleware :: LogLevel -> Wai.Middleware
 middleware logLevel = case logLevel of
   LogInfo  -> requestLogger (const True)
@@ -69,62 +51,9 @@ middleware logLevel = case logLevel of
       }
 
 logObservation :: LoggerState -> Observation -> IO ()
-logObservation loggerState obs =
+logObservation loggerState obs = logWithZTime loggerState $ observationMessage obs
-  case obs of
+
-    AdminStartObs port ->
+logWithZTime :: LoggerState -> Text -> IO ()
-      logWithZTime loggerState $ "Admin server listening on port " <> show (fromIntegral (fromJust port) :: Integer)
+logWithZTime loggerState txt = do
-    AppStartObs ver ->
+  zTime <- stateGetZTime loggerState
-      logWithZTime loggerState $ "Starting PostgREST " <> T.decodeUtf8 ver <> "..."
+  hPutStrLn stderr $ toS (formatTime defaultTimeLocale "%d/%b/%Y:%T %z: " zTime) <> txt
-    AppServerPortObs port ->
-      logWithZTime loggerState $ "Listening on port " <> show port
-    AppServerUnixObs sock ->
-      logWithZTime loggerState $ "Listening on unix socket " <> show sock
-    AppDBConnectAttemptObs ->
-      logWithZTime loggerState "Attempting to connect to the database..."
-    AppExitFatalObs reason ->
-      logWithZTime loggerState $ "Fatal error encountered. " <> reason
-    AppExitDBNoRecoveryObs ->
-      logWithZTime loggerState "Automatic recovery disabled, exiting."
-    AppDBConnectedObs ver ->
-      logWithZTime loggerState $ "Successfully connected to " <> ver
-    AppSCacheFatalErrorObs usageErr hint -> do
-      logWithZTime loggerState "A fatal error ocurred when loading the schema cache"
-      logPgrstError loggerState usageErr
-      logWithZTime loggerState hint
-    AppSCacheNormalErrorObs usageErr -> do
-      logWithZTime loggerState "An error ocurred when loading the schema cache"
-      logPgrstError loggerState usageErr
-    AppSCacheLoadSuccessObs sCache resultTime -> do
-      logWithZTime loggerState $ "Schema cache queried in " <> showMillis resultTime  <> " milliseconds"
-      logWithZTime loggerState $ "Schema cache loaded " <> showSummary sCache
-    ConnectionRetryObs delay -> do
-      logWithZTime loggerState $ "Attempting to reconnect to the database in " <> (show delay::Text) <> " seconds..."
-    ConnectionPgVersionErrorObs usageErr ->
-      logPgrstError loggerState usageErr
-    DBListenerStart channel -> do
-      logWithZTime loggerState $ "Listening for notifications on the " <> channel <> " channel"
-    DBListenerFailNoRecoverObs ->
-      logWithZTime loggerState "Automatic recovery disabled, exiting."
-    DBListenerFailRecoverObs channel ->
-      logWithZTime loggerState $ "Retrying listening for notifications on the " <> channel <> " channel.."
-    ConfigReadErrorObs ->
-      logWithZTime loggerState "An error ocurred when trying to query database settings for the config parameters"
-    ConfigReadErrorFatalObs usageErr hint -> do
-      logPgrstError loggerState usageErr
-      logWithZTime loggerState hint
-    ConfigReadErrorNotFatalObs usageErr -> do
-      logPgrstError loggerState usageErr
-    QueryRoleSettingsErrorObs usageErr -> do
-      logWithZTime loggerState "An error ocurred when trying to query the role settings"
-      logPgrstError loggerState usageErr
-    QueryErrorCodeHighObs usageErr -> do
-      logPgrstError loggerState usageErr
-    ConfigInvalidObs err -> do
-      logWithZTime loggerState $ "Failed reloading config: " <> err
-    ConfigSucceededObs -> do
-      logWithZTime loggerState "Config reloaded"
-    PoolAcqTimeoutObs usageErr -> do
-      logPgrstError loggerState usageErr
-  where
-    showMillis :: Double -> Text
-    showMillis x = toS $ showFFloat (Just 1) (x * 1000) ""

src/PostgREST/Observation.hs

@@ -1,29 +1,37 @@
+{-# LANGUAGE LambdaCase #-}
 {-|
 Module      : PostgREST.Observation
 Description : Module for observability types
 -}
 module PostgREST.Observation
   ( Observation(..)
+  , observationMessage
   ) where
 
+import qualified Data.ByteString.Lazy  as LBS
+import qualified Data.Text.Encoding    as T
 import qualified Hasql.Pool            as SQL
 import qualified Network.Socket        as NS
-import           PostgREST.SchemaCache (SchemaCache)
+import           Numeric               (showFFloat)
+import qualified PostgREST.Error       as Error
+import           PostgREST.SchemaCache (SchemaCache, showSummary)
 
 import Protolude
+import Protolude.Partial (fromJust)
 
 data Observation
   = AdminStartObs (Maybe Int)
-  | AppStartObs ByteString
+  | AppServerStartObs ByteString
   | AppServerPortObs NS.PortNumber
   | AppServerUnixObs FilePath
-  | AppDBConnectAttemptObs
+  | DBConnectAttemptObs
-  | AppExitFatalObs Text
+  | ExitFatalObs Text
-  | AppExitDBNoRecoveryObs
+  | ExitDBNoRecoveryObs
-  | AppDBConnectedObs Text
+  | DBConnectedObs Text
-  | AppSCacheFatalErrorObs SQL.UsageError Text
+  | SchemaCacheFatalErrorObs SQL.UsageError Text
-  | AppSCacheNormalErrorObs SQL.UsageError
+  | SchemaCacheNormalErrorObs SQL.UsageError
-  | AppSCacheLoadSuccessObs SchemaCache Double
+  | SchemaCacheQueriedObs Double
+  | SchemaCacheLoadedObs SchemaCache
   | ConnectionRetryObs Int
   | ConnectionPgVersionErrorObs SQL.UsageError
   | DBListenerStart Text
@@ -37,3 +45,61 @@ data Observation
   | QueryRoleSettingsErrorObs SQL.UsageError
   | QueryErrorCodeHighObs SQL.UsageError
   | PoolAcqTimeoutObs SQL.UsageError
+
+observationMessage :: Observation -> Text
+observationMessage = \case
+  AdminStartObs port ->
+    "Admin server listening on port " <> show (fromIntegral (fromJust port) :: Integer)
+  AppServerStartObs ver ->
+    "Starting PostgREST " <> T.decodeUtf8 ver <> "..."
+  AppServerPortObs port ->
+    "Listening on port " <> show port
+  AppServerUnixObs sock ->
+    "Listening on unix socket " <> show sock
+  DBConnectAttemptObs ->
+    "Attempting to connect to the database..."
+  ExitFatalObs reason ->
+    "Fatal error encountered. " <> reason
+  ExitDBNoRecoveryObs ->
+    "Automatic recovery disabled, exiting."
+  DBConnectedObs ver ->
+    "Successfully connected to " <> ver
+  SchemaCacheFatalErrorObs usageErr hint ->
+    "A fatal error ocurred when loading the schema cache. " <> hint <> ". " <> jsonMessage usageErr
+  SchemaCacheNormalErrorObs usageErr ->
+    "An error ocurred when loading the schema cache. " <> jsonMessage usageErr
+  SchemaCacheQueriedObs resultTime ->
+    "Schema cache queried in " <> showMillis resultTime  <> " milliseconds"
+  SchemaCacheLoadedObs sCache ->
+    "Schema cache loaded " <> showSummary sCache
+  ConnectionRetryObs delay ->
+    "Attempting to reconnect to the database in " <> (show delay::Text) <> " seconds..."
+  ConnectionPgVersionErrorObs usageErr ->
+    jsonMessage usageErr
+  DBListenerStart channel -> do
+    "Listening for notifications on the " <> channel <> " channel"
+  DBListenerFailNoRecoverObs ->
+    "Automatic recovery disabled, exiting."
+  DBListenerFailRecoverObs channel ->
+    "Retrying listening for notifications on the " <> channel <> " channel.."
+  ConfigReadErrorObs ->
+    "An error ocurred when trying to query database settings for the config parameters"
+  ConfigReadErrorFatalObs usageErr hint ->
+    hint <> ". " <> jsonMessage usageErr
+  ConfigReadErrorNotFatalObs usageErr ->
+    jsonMessage usageErr
+  QueryRoleSettingsErrorObs usageErr ->
+    "An error ocurred when trying to query the role settings. " <> jsonMessage usageErr
+  QueryErrorCodeHighObs usageErr ->
+    jsonMessage usageErr
+  ConfigInvalidObs err ->
+    "Failed reloading config: " <> err
+  ConfigSucceededObs ->
+     "Config reloaded"
+  PoolAcqTimeoutObs usageErr ->
+    jsonMessage usageErr
+  where
+    showMillis :: Double -> Text
+    showMillis x = toS $ showFFloat (Just 1) (x * 1000) ""
+
+    jsonMessage err = T.decodeUtf8 . LBS.toStrict . Error.errorPayload $ Error.PgError False err