diff --git a/postgrest.cabal b/postgrest.cabal index f255d9a9b4..d3887b7bfb 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -54,6 +54,7 @@ library PostgREST.Error PostgREST.Logger PostgREST.MediaType + PostgREST.Observation PostgREST.Query PostgREST.Query.QueryBuilder PostgREST.Query.SqlFragment diff --git a/src/PostgREST/Admin.hs b/src/PostgREST/Admin.hs index b5122f3067..b996895526 100644 --- a/src/PostgREST/Admin.hs +++ b/src/PostgREST/Admin.hs @@ -16,32 +16,32 @@ import qualified Data.ByteString.Lazy as LBS import Network.Socket import Network.Socket.ByteString -import PostgREST.AppState (AppState) -import PostgREST.Config (AppConfig (..)) +import PostgREST.AppState (AppState) +import PostgREST.Config (AppConfig (..)) +import PostgREST.Observation (Observation (..)) import qualified PostgREST.AppState as AppState import qualified PostgREST.Config as Config import Protolude -import Protolude.Partial (fromJust) -runAdmin :: AppConfig -> AppState -> Warp.Settings -> IO () -runAdmin conf@AppConfig{configAdminServerPort} appState settings = +runAdmin :: AppConfig -> AppState -> Warp.Settings -> (Observation -> IO ()) -> IO () +runAdmin conf@AppConfig{configAdminServerPort} appState settings observer = whenJust (AppState.getSocketAdmin appState) $ \adminSocket -> do - AppState.logWithZTime appState $ "Admin server listening on port " <> show (fromIntegral (fromJust configAdminServerPort) :: Integer) + observer $ AdminStartObs configAdminServerPort void . forkIO $ Warp.runSettingsSocket settings adminSocket adminApp where - adminApp = admin appState conf + adminApp = admin appState conf observer -- | PostgREST admin application -admin :: AppState.AppState -> AppConfig -> Wai.Application -admin appState appConfig req respond = do +admin :: AppState.AppState -> AppConfig -> (Observation -> IO ()) -> Wai.Application +admin appState appConfig observer req respond = do isMainAppReachable <- isRight <$> reachMainApp (AppState.getSocketREST appState) isSchemaCacheLoaded <- isJust <$> AppState.getSchemaCache appState isConnectionUp <- if configDbChannelEnabled appConfig then AppState.getIsListenerOn appState - else isRight <$> AppState.usePool appState appConfig (SQL.sql "SELECT 1") + else isRight <$> AppState.usePool appState appConfig (SQL.sql "SELECT 1") observer case Wai.pathInfo req of ["ready"] -> diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 2ac3f34b9b..edfd007b22 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -50,6 +50,7 @@ import PostgREST.Auth (AuthResult (..)) import PostgREST.Config (AppConfig (..)) import PostgREST.Config.PgVersion (PgVersion (..)) import PostgREST.Error (Error) +import PostgREST.Observation (Observation (..)) import PostgREST.Query (DbHandler) import PostgREST.Response.Performance (ServerTiming (..), serverTimingHeader) @@ -66,26 +67,26 @@ import System.TimeIt (timeItT) type Handler = ExceptT Error -run :: AppState -> IO () -run appState = do - AppState.logWithZTime appState $ "Starting PostgREST " <> T.decodeUtf8 prettyVersion <> "..." +run :: AppState -> (Observation -> IO ()) -> IO () +run appState observer = do + observer $ AppStartObs 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) + Unix.installSignalHandlers (AppState.getMainThreadId appState) (AppState.connectionWorker appState) (AppState.reReadConfig False appState observer) -- reload schema cache + config on NOTIFY - AppState.runListener conf appState + AppState.runListener conf appState observer - Admin.runAdmin conf appState $ serverSettings conf + Admin.runAdmin conf appState (serverSettings conf) observer - let app = postgrest conf appState (AppState.connectionWorker appState) + let app = postgrest conf appState (AppState.connectionWorker appState) observer - what <- case configServerUnixSocket of - Just path -> pure $ "unix socket " <> show path + case configServerUnixSocket of + Just path -> do + observer $ AppServerUnixObs path Nothing -> do port <- NS.socketPort $ AppState.getSocketREST appState - pure $ "port " <> show port - AppState.logWithZTime appState $ "Listening on " <> what + observer $ AppServerPortObs port Warp.runSettingsSocket (serverSettings conf) (AppState.getSocketREST appState) app @@ -97,8 +98,8 @@ serverSettings AppConfig{..} = & setServerName ("postgrest/" <> prettyVersion) -- | PostgREST application -postgrest :: AppConfig -> AppState.AppState -> IO () -> Wai.Application -postgrest conf appState connWorker = +postgrest :: AppConfig -> AppState.AppState -> IO () -> (Observation -> IO ()) -> Wai.Application +postgrest conf appState connWorker observer = traceHeaderMiddleware conf . Cors.middleware (configServerCorsAllowedOrigins conf) . Auth.middleware appState . @@ -115,7 +116,7 @@ postgrest conf appState connWorker = let eitherResponse :: IO (Either Error Wai.Response) eitherResponse = - runExceptT $ postgrestResponse appState appConf maybeSchemaCache pgVer authResult req + runExceptT $ postgrestResponse appState appConf maybeSchemaCache pgVer authResult req observer response <- either Error.errorResponseFor identity <$> eitherResponse -- Launch the connWorker when the connection is down. The postgrest @@ -134,8 +135,9 @@ postgrestResponse -> PgVersion -> AuthResult -> Wai.Request + -> (Observation -> IO ()) -> Handler IO Wai.Response -postgrestResponse appState conf@AppConfig{..} maybeSchemaCache pgVer authResult@AuthResult{..} req = do +postgrestResponse appState conf@AppConfig{..} maybeSchemaCache pgVer authResult@AuthResult{..} req observer = do sCache <- case maybeSchemaCache of Just sCache -> @@ -151,13 +153,13 @@ postgrestResponse appState conf@AppConfig{..} maybeSchemaCache pgVer authResult@ ApiRequest.userApiRequest conf req body sCache let jwtTime = if configServerTimingEnabled then Auth.getJwtDur req else Nothing - handleRequest authResult conf appState (Just authRole /= configDbAnonRole) configDbPreparedStatements pgVer apiRequest sCache jwtTime parseTime + handleRequest authResult conf appState (Just authRole /= configDbAnonRole) configDbPreparedStatements pgVer apiRequest sCache jwtTime parseTime observer -runDbHandler :: AppState.AppState -> AppConfig -> SQL.IsolationLevel -> SQL.Mode -> Bool -> Bool -> DbHandler b -> Handler IO b -runDbHandler appState config isoLvl mode authenticated prepared handler = do +runDbHandler :: AppState.AppState -> AppConfig -> SQL.IsolationLevel -> SQL.Mode -> Bool -> Bool -> (Observation -> IO ()) -> DbHandler b -> Handler IO b +runDbHandler appState config isoLvl mode authenticated prepared observer handler = do dbResp <- lift $ do let transaction = if prepared then SQL.transaction else SQL.unpreparedTransaction - AppState.usePool appState config . transaction isoLvl mode $ runExceptT handler + AppState.usePool appState config (transaction isoLvl mode $ runExceptT handler) observer resp <- liftEither . mapLeft Error.PgErr $ @@ -165,8 +167,9 @@ runDbHandler appState config isoLvl mode authenticated prepared handler = do liftEither resp -handleRequest :: AuthResult -> AppConfig -> AppState.AppState -> Bool -> Bool -> PgVersion -> ApiRequest -> SchemaCache -> Maybe Double -> Maybe Double -> Handler IO Wai.Response -handleRequest AuthResult{..} conf appState authenticated prepared pgVer apiReq@ApiRequest{..} sCache jwtTime parseTime = +handleRequest :: AuthResult -> AppConfig -> AppState.AppState -> Bool -> Bool -> PgVersion -> ApiRequest -> SchemaCache -> + Maybe Double -> Maybe Double -> (Observation -> IO ()) -> Handler IO Wai.Response +handleRequest AuthResult{..} conf appState authenticated prepared pgVer apiReq@ApiRequest{..} sCache jwtTime parseTime observer = case (iAction, iTarget) of (ActionRead headersOnly, TargetIdent identifier) -> do (planTime', wrPlan) <- withTiming $ liftEither $ Plan.wrappedReadPlan identifier conf sCache apiReq @@ -231,7 +234,7 @@ handleRequest AuthResult{..} conf appState authenticated prepared pgVer apiReq@A roleSettings = fromMaybe mempty (HM.lookup authRole $ configRoleSettings conf) roleIsoLvl = HM.findWithDefault SQL.ReadCommitted authRole $ configRoleIsoLvl conf runQuery isoLvl funcSets mode query = - runDbHandler appState conf isoLvl mode authenticated prepared $ do + runDbHandler appState conf isoLvl mode authenticated prepared observer $ do Query.setPgLocals conf authClaims authRole (HM.toList roleSettings) funcSets apiReq Query.runPreReq conf query diff --git a/src/PostgREST/AppState.hs b/src/PostgREST/AppState.hs index 1b6ce80a79..4aac3014ad 100644 --- a/src/PostgREST/AppState.hs +++ b/src/PostgREST/AppState.hs @@ -19,7 +19,6 @@ module PostgREST.AppState , init , initSockets , initWithPool - , logWithZTime , putSchemaCache , putPgVersion , usePool @@ -32,11 +31,9 @@ module PostgREST.AppState import qualified Data.Aeson as JSON import qualified Data.Aeson.KeyMap as KM import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy as LBS import qualified Data.Cache as C import Data.Either.Combinators (whenLeft) import qualified Data.Text as T (unpack) -import qualified Data.Text.Encoding as T import Hasql.Connection (acquire) import qualified Hasql.Notifications as SQL import qualified Hasql.Pool as SQL @@ -45,6 +42,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 PostgREST.Observation import PostgREST.Version (prettyVersion) import System.TimeIt (timeItT) @@ -55,12 +53,8 @@ import Control.Retry (RetryStatus, capDelay, exponentialBackoff, retrying, rsPreviousDelay) import Data.IORef (IORef, atomicWriteIORef, newIORef, readIORef) -import Data.Time (ZonedTime, defaultTimeLocale, formatTime, - getZonedTime) import Data.Time.Clock (UTCTime, getCurrentTime) -import Numeric (showFFloat) - import PostgREST.Config (AppConfig (..), LogLevel (..), addFallbackAppName, @@ -71,8 +65,7 @@ import PostgREST.Config.Database (queryDbSettings, import PostgREST.Config.PgVersion (PgVersion (..), minimumPgVersion) import PostgREST.SchemaCache (SchemaCache (..), - querySchemaCache, - showSummary) + querySchemaCache) import PostgREST.SchemaCache.Identifiers (dumpQi) import PostgREST.Unix (createAndBindDomainSocket) @@ -102,14 +95,12 @@ data AppState = AppState , stateConf :: IORef AppConfig -- | Time used for verifying JWT expiration , stateGetTime :: IO UTCTime - -- | Time with time zone used for worker logs - , stateGetZTime :: IO ZonedTime -- | Used for killing the main thread in case a subthread fails , stateMainThreadId :: ThreadId -- | Keeps track of when the next retry for connecting to database is scheduled , stateRetryNextIn :: IORef Int - -- | Logs a pool error with a debounce - , debounceLogAcquisitionTimeout :: IO () + -- | Emits a pool error observation with a debounce + , debounceAcquisitionTimeoutObs :: IO () -- | JWT Cache , jwtCache :: C.Cache ByteString AuthResult -- | Network socket for REST API @@ -120,15 +111,15 @@ data AppState = AppState type AppSockets = (NS.Socket, Maybe NS.Socket) -init :: AppConfig -> IO AppState -init conf = do +init :: AppConfig -> (Observation -> IO ()) -> IO AppState +init conf observer = do pool <- initPool conf (sock, adminSock) <- initSockets conf - state' <- initWithPool (sock, adminSock) pool conf + state' <- initWithPool (sock, adminSock) pool conf observer pure state' { stateSocketREST = sock, stateSocketAdmin = adminSock } -initWithPool :: AppSockets -> SQL.Pool -> AppConfig -> IO AppState -initWithPool (sock, adminSock) pool conf = do +initWithPool :: AppSockets -> SQL.Pool -> AppConfig -> (Observation -> IO() ) -> IO AppState +initWithPool (sock, adminSock) pool conf 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 @@ -137,7 +128,6 @@ initWithPool (sock, adminSock) pool conf = do <*> newIORef False <*> newIORef conf <*> mkAutoUpdate defaultUpdateSettings { updateAction = getCurrentTime } - <*> mkAutoUpdate defaultUpdateSettings { updateAction = getZonedTime } <*> myThreadId <*> newIORef 0 <*> pure (pure ()) @@ -146,10 +136,10 @@ initWithPool (sock, adminSock) pool conf = do <*> pure adminSock - debLogTimeout <- + debPoolTimeout <- let oneSecond = 1000000 in mkDebounce defaultDebounceSettings - { debounceAction = logPgrstError appState SQL.AcquisitionTimeoutUsageError + { debounceAction = observer $ PoolAcqTimeoutObs SQL.AcquisitionTimeoutUsageError , debounceFreq = 5*oneSecond , debounceEdge = leadingEdge -- logs at the start and the end } @@ -157,12 +147,12 @@ initWithPool (sock, adminSock) pool conf = do debWorker <- let decisecond = 100000 in mkDebounce defaultDebounceSettings - { debounceAction = internalConnectionWorker appState + { debounceAction = internalConnectionWorker appState observer , debounceFreq = decisecond , debounceEdge = leadingEdge -- runs the worker at the start and the end } - return appState { debounceLogAcquisitionTimeout = debLogTimeout, debouncedConnectionWorker = debWorker } + return appState { debounceAcquisitionTimeoutObs = debPoolTimeout, debouncedConnectionWorker = debWorker } destroy :: AppState -> IO () destroy = destroyPool @@ -210,16 +200,17 @@ 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@AppState{..} AppConfig{configLogLevel} x = do - res <- SQL.use statePool x +usePool :: AppState -> AppConfig -> SQL.Session a -> (Observation -> IO ()) -> IO (Either SQL.UsageError a) +usePool AppState{..} AppConfig{configLogLevel} sess observer = do + res <- SQL.use statePool sess when (configLogLevel > LogCrit) $ do whenLeft res (\case - SQL.AcquisitionTimeoutUsageError -> debounceLogAcquisitionTimeout -- this can happen rapidly for many requests, so we debounce + -- TODO debouncing will not be correct if we want to have a metric for the amount of timeouts + SQL.AcquisitionTimeoutUsageError -> debounceAcquisitionTimeoutObs -- this can happen rapidly for many requests, so we debounce. 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 -> logPgrstError appState error + | Error.status (Error.PgError False error) >= HTTP.status500 -> observer $ QueryErrorCodeHighObs error | otherwise -> pure ()) return res @@ -272,15 +263,6 @@ getSocketREST = stateSocketREST getSocketAdmin :: AppState -> Maybe NS.Socket getSocketAdmin = stateSocketAdmin --- | Log to stderr with local time -logWithZTime :: AppState -> Text -> IO () -logWithZTime appState txt = do - zTime <- stateGetZTime appState - hPutStrLn stderr $ toS (formatTime defaultTimeLocale "%d/%b/%Y:%T %z: " zTime) <> txt - -logPgrstError :: AppState -> SQL.UsageError -> IO () -logPgrstError appState e = logWithZTime appState . T.decodeUtf8 . LBS.toStrict $ Error.errorPayload $ Error.PgError False e - getMainThreadId :: AppState -> ThreadId getMainThreadId = stateMainThreadId @@ -308,35 +290,27 @@ data SCacheStatus | SCFatalFail -- | Load the SchemaCache by using a connection from the pool. -loadSchemaCache :: AppState -> IO SCacheStatus -loadSchemaCache appState = do +loadSchemaCache :: AppState -> (Observation -> IO()) -> IO SCacheStatus +loadSchemaCache appState 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 conf (transaction SQL.ReadCommitted SQL.Read $ querySchemaCache conf) observer case result of Left e -> do case checkIsFatal e of Just hint -> do - logWithZTime appState "A fatal error ocurred when loading the schema cache" - logPgrstError appState e - logWithZTime appState hint + observer $ AppSCacheFatalErrorObs e hint return SCFatalFail Nothing -> do putSchemaCache appState Nothing - logWithZTime appState "An error ocurred when loading the schema cache" - logPgrstError appState e + observer $ AppSCacheNormalErrorObs e return SCOnRetry Right sCache -> do putSchemaCache appState $ Just sCache - logWithZTime appState $ "Schema cache queried in " <> showMillis resultTime <> " milliseconds" - logWithZTime appState $ "Schema cache loaded " <> showSummary sCache + observer $ AppSCacheLoadSuccessObs sCache resultTime return SCLoaded - where - showMillis :: Double -> Text - showMillis x = toS $ showFFloat (Just 1) (x * 1000) "" -- | Current database connection status data ConnectionStatus data ConnectionStatus @@ -356,31 +330,31 @@ 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 -> IO () -internalConnectionWorker appState = work +internalConnectionWorker :: AppState -> (Observation -> IO()) -> IO () +internalConnectionWorker appState observer = work where work = do config@AppConfig{..} <- getConfig appState - logWithZTime appState "Attempting to connect to the database..." - connected <- establishConnection appState config + observer AppDBConnectAttemptObs + connected <- establishConnection appState config observer case connected of FatalConnectionError reason -> -- Fatal error when connecting - logWithZTime appState reason >> killThread (getMainThreadId appState) + observer (AppExitFatalObs reason) >> killThread (getMainThreadId appState) NotConnected -> -- Unreachable because establishConnection will keep trying to connect, unless disable-recovery is turned on unless configDbPoolAutomaticRecovery - $ logWithZTime appState "Automatic recovery disabled, exiting." >> killThread (getMainThreadId appState) + $ observer AppExitDBNoRecoveryObs >> killThread (getMainThreadId appState) Connected actualPgVersion -> do -- Procede with initialization putPgVersion appState actualPgVersion when configDbChannelEnabled $ signalListener appState - logWithZTime appState $ "Successfully connected to " <> pgvFullName actualPgVersion + observer (AppDBConnectedObs $ 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 - scStatus <- loadSchemaCache appState + when configDbConfig $ reReadConfig False appState observer + scStatus <- loadSchemaCache appState observer case scStatus of SCLoaded -> -- do nothing and proceed if the load was successful @@ -402,8 +376,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 = +establishConnection :: AppState -> AppConfig -> (Observation -> IO ()) -> IO ConnectionStatus +establishConnection appState config observer = retrying retrySettings shouldRetry $ const $ flushPool appState >> getConnectionStatus where @@ -413,10 +387,10 @@ establishConnection appState config = 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 config (queryPgVersion False) observer -- No need to prepare the query here, as the connection might not be established case pgVersion of Left e -> do - logPgrstError appState e + observer $ ConnectionPgVersionErrorObs e case checkIsFatal e of Just reason -> return $ FatalConnectionError reason @@ -436,43 +410,37 @@ establishConnection appState config = let delay = fromMaybe 0 (rsPreviousDelay rs) `div` backoffMicroseconds itShould = NotConnected == isConnSucc && configDbPoolAutomaticRecovery - when itShould . logWithZTime appState $ - "Attempting to reconnect to the database in " - <> (show delay::Text) - <> " seconds..." + when itShould $ observer $ ConnectionRetryObs delay when itShould $ putRetryNextIn appState delay return itShould -- | Re-reads the config plus config options from the db -reReadConfig :: Bool -> AppState -> IO () -reReadConfig startingUp appState = do +reReadConfig :: Bool -> AppState -> (Observation -> IO ()) -> IO () +reReadConfig startingUp appState observer = do config@AppConfig{..} <- getConfig appState pgVer <- getPgVersion appState dbSettings <- if configDbConfig then do - qDbSettings <- usePool appState config $ queryDbSettings (dumpQi <$> configDbPreConfig) configDbPreparedStatements + qDbSettings <- usePool appState config (queryDbSettings (dumpQi <$> configDbPreConfig) configDbPreparedStatements) observer case qDbSettings of Left e -> do - logWithZTime appState - "An error ocurred when trying to query database settings for the config parameters" + observer ConfigReadErrorObs case checkIsFatal e of Just hint -> do - logPgrstError appState e - logWithZTime appState hint + observer $ ConfigReadErrorFatalObs e hint killThread (getMainThreadId appState) Nothing -> do - logPgrstError appState e + observer $ ConfigReadErrorNotFatalObs e pure mempty Right x -> pure x else pure mempty (roleSettings, roleIsolationLvl) <- if configDbConfig then do - rSettings <- usePool appState config $ queryRoleSettings pgVer configDbPreparedStatements + rSettings <- usePool appState config (queryRoleSettings pgVer configDbPreparedStatements) observer case rSettings of Left e -> do - logWithZTime appState "An error ocurred when trying to query the role settings" - logPgrstError appState e + observer $ QueryRoleSettingsErrorObs e pure (mempty, mempty) Right x -> pure x else @@ -482,24 +450,23 @@ reReadConfig startingUp appState = do if startingUp then panic err -- die on invalid config if the program is starting up else - logWithZTime appState $ "Failed reloading config: " <> err + observer $ ConfigInvalidObs err Right newConf -> do putConfig appState newConf if startingUp then pass else - logWithZTime appState "Config reloaded" - + observer ConfigSucceededObs -runListener :: AppConfig -> AppState -> IO () -runListener AppConfig{configDbChannelEnabled} appState = - when configDbChannelEnabled $ listener appState +runListener :: AppConfig -> AppState -> (Observation -> IO ()) -> IO () +runListener AppConfig{configDbChannelEnabled} appState observer = + when configDbChannelEnabled $ listener appState observer -- | Starts a dedicated pg connection to LISTEN for notifications. When a -- NOTIFY - with an empty payload - is done, it refills the schema -- cache. It uses the connectionWorker in case the LISTEN connection dies. -listener :: AppState -> IO () -listener appState = do +listener :: AppState -> (Observation -> IO ()) -> IO () +listener appState observer = do AppConfig{..} <- getConfig appState let dbChannel = toS configDbChannel @@ -514,28 +481,29 @@ listener appState = do dbOrError <- acquire $ toUtf8 (addFallbackAppName prettyVersion configDbUri) case dbOrError of Right db -> do - logWithZTime appState $ "Listening for notifications on the " <> dbChannel <> " channel" + observer $ DBListenerStart dbChannel putIsListenerOn appState True SQL.listen db $ SQL.toPgIdentifier dbChannel SQL.waitForNotifications handleNotification db _ -> die $ "Could not listen for notifications on the " <> dbChannel <> " channel" where - handleFinally _ False _ = - logWithZTime appState "Automatic recovery disabled, exiting." >> killThread (getMainThreadId appState) + handleFinally _ False _ = do + observer DBListenerFailNoRecoverObs + killThread (getMainThreadId appState) handleFinally dbChannel True _ = do -- if the thread dies, we try to recover - logWithZTime appState $ "Retrying listening for notifications on the " <> dbChannel <> " channel.." + observer $ DBListenerFailRecoverObs dbChannel putIsListenerOn appState False -- assume the pool connection was also lost, call the connection worker connectionWorker appState -- retry the listener - listener appState + listener appState observer handleNotification _ msg | BS.null msg = cacheReloader | msg == "reload schema" = cacheReloader - | msg == "reload config" = reReadConfig False appState + | msg == "reload config" = reReadConfig False appState observer | otherwise = pure () -- Do nothing if anything else than an empty message is sent cacheReloader = diff --git a/src/PostgREST/CLI.hs b/src/PostgREST/CLI.hs index 363f1cb05b..2e9f79be71 100644 --- a/src/PostgREST/CLI.hs +++ b/src/PostgREST/CLI.hs @@ -25,6 +25,7 @@ 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) @@ -34,18 +35,19 @@ main CLI{cliCommand, cliPath} = do conf@AppConfig{..} <- either panic identity <$> Config.readAppConfig mempty cliPath Nothing mempty mempty + loggerState <- Logger.init -- 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) + (AppState.init conf $ Logger.logObservation loggerState) AppState.destroy (\appState -> case cliCommand of CmdDumpConfig -> do - when configDbConfig $ AppState.reReadConfig True appState + when configDbConfig $ AppState.reReadConfig True appState (const $ pure ()) putStr . Config.toText =<< AppState.getConfig appState CmdDumpSchema -> putStrLn =<< dumpSchema appState - CmdRun -> App.run appState) + CmdRun -> App.run appState (Logger.logObservation loggerState)) -- | Dump SchemaCache schema to JSON dumpSchema :: AppState -> IO LBS.ByteString @@ -53,9 +55,9 @@ dumpSchema appState = do conf@AppConfig{..} <- AppState.getConfig appState result <- let transaction = if configDbPreparedStatements then SQL.transaction else SQL.unpreparedTransaction in - AppState.usePool appState conf $ - transaction SQL.ReadCommitted SQL.Read $ - querySchemaCache conf + 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 diff --git a/src/PostgREST/Logger.hs b/src/PostgREST/Logger.hs index 08d43b2d0f..e8d1ed738e 100644 --- a/src/PostgREST/Logger.hs +++ b/src/PostgREST/Logger.hs @@ -2,18 +2,57 @@ Module : PostgREST.Logger Description : Wai Middleware to log requests to stdout. -} -module PostgREST.Logger (middleware) where +module PostgREST.Logger + ( middleware + , logObservation + , init + ) where + +import Control.AutoUpdate (defaultUpdateSettings, mkAutoUpdate, + updateAction) + +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Text.Encoding as T +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) -import qualified PostgREST.Auth as Auth -import PostgREST.Config (LogLevel (..)) +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 + } + +init :: IO LoggerState +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 @@ -28,3 +67,64 @@ middleware logLevel = case logLevel of & Wai.setApacheRequestFilter (\_ res -> filterStatus $ Wai.responseStatus res) & Wai.setApacheUserGetter Auth.getRole } + +logObservation :: LoggerState -> Observation -> IO () +logObservation loggerState obs = + case obs of + AdminStartObs port -> + logWithZTime loggerState $ "Admin server listening on port " <> show (fromIntegral (fromJust port) :: Integer) + AppStartObs ver -> + logWithZTime loggerState $ "Starting PostgREST " <> T.decodeUtf8 ver <> "..." + 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) "" diff --git a/src/PostgREST/Observation.hs b/src/PostgREST/Observation.hs new file mode 100644 index 0000000000..fabb3cb149 --- /dev/null +++ b/src/PostgREST/Observation.hs @@ -0,0 +1,39 @@ +{-| +Module : PostgREST.Observation +Description : Module for observability types +-} +module PostgREST.Observation + ( Observation(..) + ) where + +import qualified Hasql.Pool as SQL +import qualified Network.Socket as NS +import PostgREST.SchemaCache (SchemaCache) + +import Protolude + +data Observation + = AdminStartObs (Maybe Int) + | AppStartObs ByteString + | AppServerPortObs NS.PortNumber + | AppServerUnixObs FilePath + | AppDBConnectAttemptObs + | AppExitFatalObs Text + | AppExitDBNoRecoveryObs + | AppDBConnectedObs Text + | AppSCacheFatalErrorObs SQL.UsageError Text + | AppSCacheNormalErrorObs SQL.UsageError + | AppSCacheLoadSuccessObs SchemaCache Double + | ConnectionRetryObs Int + | ConnectionPgVersionErrorObs SQL.UsageError + | DBListenerStart Text + | DBListenerFailNoRecoverObs + | DBListenerFailRecoverObs Text + | ConfigReadErrorObs + | ConfigReadErrorFatalObs SQL.UsageError Text + | ConfigReadErrorNotFatalObs SQL.UsageError + | ConfigInvalidObs Text + | ConfigSucceededObs + | QueryRoleSettingsErrorObs SQL.UsageError + | QueryErrorCodeHighObs SQL.UsageError + | PoolAcqTimeoutObs SQL.UsageError diff --git a/test/spec/Main.hs b/test/spec/Main.hs index 8ae6cdb411..a6edf23670 100644 --- a/test/spec/Main.hs +++ b/test/spec/Main.hs @@ -73,24 +73,25 @@ main = do actualPgVersion <- either (panic . show) id <$> P.use pool (queryPgVersion False) -- cached schema cache so most tests run fast - baseSchemaCache <- loadSchemaCache pool testCfg + baseSchemaCache <- loadSCache pool testCfg 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 + appState <- AppState.initWithPool sockets pool config noObs AppState.putPgVersion appState actualPgVersion AppState.putSchemaCache appState (Just baseSchemaCache) - return ((), postgrest config appState $ pure ()) + return ((), postgrest config appState (pure ()) noObs) -- For tests that run with a different SchemaCache(depends on configSchemas) appDbs config = do - customSchemaCache <- loadSchemaCache pool config - appState <- AppState.initWithPool sockets pool config + customSchemaCache <- loadSCache pool config + appState <- AppState.initWithPool sockets pool config noObs AppState.putPgVersion appState actualPgVersion AppState.putSchemaCache appState (Just customSchemaCache) - return ((), postgrest config appState $ pure ()) + return ((), postgrest config appState (pure ()) noObs) let withApp = app testCfg maxRowsApp = app testMaxRowsCfg @@ -268,5 +269,5 @@ main = do describe "Feature.RollbackForcedSpec" Feature.RollbackSpec.forced where - loadSchemaCache pool conf = + loadSCache pool conf = either (panic.show) id <$> P.use pool (HT.transaction HT.ReadCommitted HT.Read $ querySchemaCache conf)