jimmy/postgrest
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

refactor: add observation module (#3232)

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