refactor: remove auth and logging middleware

This commit removes auth middleware for it hides
side effects and obscures logic. The auth operations
are now done in its own stage in the request-response
cycle.

It also removes the logging middleware because now
we instead use observation module to log the response.
This commit is contained in:
Taimoor Zaeem
2026-05-07 11:47:17 -05:00
committed by Steve Chavez
parent 0bba1d265a
commit 98f8e52b46
9 changed files with 162 additions and 144 deletions
+2 -1
View File
@@ -70,6 +70,7 @@ library
PostgREST.Listener PostgREST.Listener
PostgREST.Logger PostgREST.Logger
PostgREST.MainTx PostgREST.MainTx
PostgREST.Logger.Apache
PostgREST.MediaType PostgREST.MediaType
PostgREST.Metrics PostgREST.Metrics
PostgREST.Network PostgREST.Network
@@ -116,6 +117,7 @@ library
, directory >= 1.2.6 && < 1.4 , directory >= 1.2.6 && < 1.4
, either >= 4.4.1 && < 5.1 , either >= 4.4.1 && < 5.1
, extra >= 1.7.0 && < 2.0 , extra >= 1.7.0 && < 2.0
, fast-logger >= 3.2.0 && < 3.3
, fuzzyset >= 0.2.4 && < 0.3 , fuzzyset >= 0.2.4 && < 0.3
, hasql >= 1.9 && <= 1.9.3.1 , hasql >= 1.9 && <= 1.9.3.1
, hasql-dynamic-statements >= 0.3.1 && <= 0.3.1.8 , hasql-dynamic-statements >= 0.3.1 && <= 0.3.1.8
@@ -147,7 +149,6 @@ library
, time >= 1.6 && < 1.15 , time >= 1.6 && < 1.15
, unordered-containers >= 0.2.8 && < 0.3 , unordered-containers >= 0.2.8 && < 0.3
, unix-compat >= 0.5.4 && < 0.8 , unix-compat >= 0.5.4 && < 0.8
, vault >= 0.3.1.5 && < 0.4
, vector >= 0.11 && < 0.14 , vector >= 0.11 && < 0.14
, wai >= 3.2.1 && < 3.3 , wai >= 3.2.1 && < 3.3
, wai-cors >= 0.2.5 && < 0.3 , wai-cors >= 0.2.5 && < 0.3
+8 -1
View File
@@ -8,6 +8,7 @@ module PostgREST.ApiRequest
( ApiRequest(..) ( ApiRequest(..)
, userApiRequest , userApiRequest
, userPreferences , userPreferences
, userBearerAuth
) where ) where
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
@@ -19,8 +20,10 @@ import qualified Data.Text.Encoding as T
import Data.List (lookup) import Data.List (lookup)
import Data.Ranged.Ranges (emptyRange, rangeIntersection, import Data.Ranged.Ranges (emptyRange, rangeIntersection,
rangeIsEmpty) rangeIsEmpty)
import Network.HTTP.Types.Header (RequestHeaders, hCookie) import Network.HTTP.Types.Header (RequestHeaders,
hAuthorization, hCookie)
import Network.Wai (Request (..)) import Network.Wai (Request (..))
import Network.Wai.Middleware.HttpAuth (extractBearerAuth)
import Network.Wai.Parse (parseHttpAccept) import Network.Wai.Parse (parseHttpAccept)
import Web.Cookie (parseCookies) import Web.Cookie (parseCookies)
@@ -114,6 +117,10 @@ userApiRequest conf prefs req reqBody = do
userPreferences :: AppConfig -> Request -> TimezoneNames -> Preferences.Preferences userPreferences :: AppConfig -> Request -> TimezoneNames -> Preferences.Preferences
userPreferences conf req timezones = Preferences.fromHeaders (configDbTxAllowOverride conf) timezones $ requestHeaders req userPreferences conf req timezones = Preferences.fromHeaders (configDbTxAllowOverride conf) timezones $ requestHeaders req
-- | Obtains the Bearer Auth
userBearerAuth :: Request -> Maybe ByteString
userBearerAuth req = extractBearerAuth =<< lookup hAuthorization (requestHeaders req)
getResource :: AppConfig -> [Text] -> Either ApiRequestError Resource getResource :: AppConfig -> [Text] -> Either ApiRequestError Resource
getResource AppConfig{configOpenApiMode, configDbRootSpec} = \case getResource AppConfig{configOpenApiMode, configDbRootSpec} = \case
[] -> [] ->
+44 -37
View File
@@ -9,6 +9,7 @@ Some of its functionality includes:
- Producing HTTP Headers according to RFCs. - Producing HTTP Headers according to RFCs.
- Content Negotiation - Content Negotiation
-} -}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ViewPatterns #-}
@@ -24,7 +25,6 @@ import System.IO.Error (ioeGetErrorType)
import Control.Monad.Except (liftEither) import Control.Monad.Except (liftEither)
import Control.Monad.Extra (whenJust) import Control.Monad.Extra (whenJust)
import Data.Either.Combinators (mapLeft, whenLeft) import Data.Either.Combinators (mapLeft, whenLeft)
import Data.Maybe (fromJust)
import Data.String (IsString (..)) import Data.String (IsString (..))
import Network.Wai.Handler.Warp (defaultSettings, setHost, import Network.Wai.Handler.Warp (defaultSettings, setHost,
setOnException, setPort, setOnException, setPort,
@@ -33,6 +33,7 @@ import Network.Wai.Handler.Warp (defaultSettings, setHost,
import qualified Data.Text.Encoding as T import qualified Data.Text.Encoding as T
import qualified Network.Wai as Wai import qualified Network.Wai as Wai
import qualified Network.Wai.Handler.Warp as Warp import qualified Network.Wai.Handler.Warp as Warp
import qualified Network.Wai.Header as WaiHeader
import qualified PostgREST.Admin as Admin import qualified PostgREST.Admin as Admin
import qualified PostgREST.ApiRequest as ApiRequest import qualified PostgREST.ApiRequest as ApiRequest
@@ -41,7 +42,6 @@ import qualified PostgREST.Auth as Auth
import qualified PostgREST.Cors as Cors import qualified PostgREST.Cors as Cors
import qualified PostgREST.Error as Error import qualified PostgREST.Error as Error
import qualified PostgREST.Listener as Listener import qualified PostgREST.Listener as Listener
import qualified PostgREST.Logger as Logger
import qualified PostgREST.MainTx as MainTx import qualified PostgREST.MainTx as MainTx
import qualified PostgREST.Plan as Plan import qualified PostgREST.Plan as Plan
import qualified PostgREST.Query as Query import qualified PostgREST.Query as Query
@@ -51,7 +51,7 @@ import qualified PostgREST.Unix as Unix (installSignalHandlers)
import PostgREST.ApiRequest (ApiRequest (..)) import PostgREST.ApiRequest (ApiRequest (..))
import PostgREST.AppState (AppState) import PostgREST.AppState (AppState)
import PostgREST.Auth.Types (AuthResult (..)) import PostgREST.Auth.Types (AuthResult (..))
import PostgREST.Config (AppConfig (..), LogLevel (..)) import PostgREST.Config (AppConfig (..))
import PostgREST.Error (Error) import PostgREST.Error (Error)
import PostgREST.Network (resolveSocketToAddress) import PostgREST.Network (resolveSocketToAddress)
import PostgREST.Observation (Observation (..)) import PostgREST.Observation (Observation (..))
@@ -72,11 +72,9 @@ import qualified Network.Socket as NS
import PostgREST.Unix (createAndBindDomainSocket) import PostgREST.Unix (createAndBindDomainSocket)
import Protolude hiding (Handler) import Protolude hiding (Handler)
type Handler = ExceptT Error
run :: AppState -> IO () run :: AppState -> IO ()
run appState = do run appState = do
conf@AppConfig{..} <- AppState.getConfig appState conf <- AppState.getConfig appState
AppState.schemaCacheLoader appState -- Loads the initial SchemaCache AppState.schemaCacheLoader appState -- Loads the initial SchemaCache
(mainSocket, adminSocket) <- initSockets conf (mainSocket, adminSocket) <- initSockets conf
@@ -89,7 +87,7 @@ run appState = do
Admin.runAdmin appState adminSocket mainSocket (serverSettings conf) Admin.runAdmin appState adminSocket mainSocket (serverSettings conf)
let app = postgrest configLogLevel appState (AppState.schemaCacheLoader appState) let app = postgrest appState (AppState.schemaCacheLoader appState)
do do
address <- resolveSocketToAddress mainSocket address <- resolveSocketToAddress mainSocket
@@ -122,27 +120,33 @@ serverSettings AppConfig{..} =
& setServerName ("postgrest/" <> prettyVersion) & setServerName ("postgrest/" <> prettyVersion)
-- | PostgREST application -- | PostgREST application
postgrest :: LogLevel -> AppState.AppState -> IO () -> Wai.Application postgrest :: AppState.AppState -> IO () -> Wai.Application
postgrest logLevel appState connWorker = postgrest appState connWorker =
traceHeaderMiddleware appState . traceHeaderMiddleware appState .
Cors.middleware appState . Cors.middleware appState $
Auth.middleware appState .
Logger.middleware logLevel Auth.getRole $
-- fromJust can be used, because the auth middleware will **always** add
-- some AuthResult to the vault.
\req respond -> do \req respond -> do
appConf@AppConfig{..} <- AppState.getConfig appState -- the config must be read again because it can reload appConf@AppConfig{..} <- AppState.getConfig appState -- the config must be read again because it can reload
case fromJust $ Auth.getResult req of
Left err -> respond $ Error.errorResponseFor configClientErrorVerbosity err
Right authResult -> do
maybeSchemaCache <- AppState.getSchemaCache appState maybeSchemaCache <- AppState.getSchemaCache appState
let let observer = AppState.getObserver appState
eitherResponse :: IO (Either Error Wai.Response) bearerAuth = ApiRequest.userBearerAuth req
eitherResponse =
runExceptT $ postgrestResponse appState appConf maybeSchemaCache authResult req response <- do
authResultE <- runExceptT $ withTiming appConf $
liftIO (Auth.getAuthResult appState bearerAuth) >>= liftEither
case authResultE of
Left err -> do
let resp = Error.errorResponseFor configClientErrorVerbosity err
observer $ genResponseObs Nothing req resp
pure resp
Right (jwtTime, authResult@AuthResult{..}) -> do
resp <- either (Error.errorResponseFor configClientErrorVerbosity) identity <$>
runExceptT (postgrestResponse appState appConf maybeSchemaCache jwtTime authResult req)
observer $ genResponseObs (Just authRole) req resp
pure resp
response <- either (Error.errorResponseFor configClientErrorVerbosity) identity <$> eitherResponse
-- Launch the connWorker when the connection is down. The postgrest -- Launch the connWorker when the connection is down. The postgrest
-- function can respond successfully (with a stale schema cache) before -- function can respond successfully (with a stale schema cache) before
-- the connWorker is done. However, when there's an empty schema cache -- the connWorker is done. However, when there's an empty schema cache
@@ -151,19 +155,24 @@ postgrest logLevel appState connWorker =
-- it would duplicate the loading process, e.g. https://github.com/PostgREST/postgrest/issues/3704 -- it would duplicate the loading process, e.g. https://github.com/PostgREST/postgrest/issues/3704
-- TODO: this process may be unnecessary when the Listener is enabled. Revisit once https://github.com/PostgREST/postgrest/issues/1766 is done -- TODO: this process may be unnecessary when the Listener is enabled. Revisit once https://github.com/PostgREST/postgrest/issues/1766 is done
when (isServiceUnavailable response && isJust maybeSchemaCache) connWorker when (isServiceUnavailable response && isJust maybeSchemaCache) connWorker
resp <- do
delay <- AppState.getNextDelay appState delay <- AppState.getNextDelay appState
return $ addRetryHint delay response respond $ addRetryHint delay response
respond resp where
-- TODO WaiHeader.contentLength does a lookup everytime, see: https://hackage.haskell.org/package/wai-extra-3.1.17/docs/src/Network.Wai.Header.html#contentLength
-- It might be possible to gain some perf by returning the response length from `postgrestResponse`. We calculate the length manually on Response.hs.
genResponseObs :: Maybe ByteString -> Wai.Request -> Wai.Response -> Observation
genResponseObs user req resp =
ResponseObs user req (Wai.responseStatus resp) (WaiHeader.contentLength $ Wai.responseHeaders resp)
postgrestResponse postgrestResponse
:: AppState.AppState :: AppState.AppState
-> AppConfig -> AppConfig
-> Maybe SchemaCache -> Maybe SchemaCache
-> Maybe Double
-> AuthResult -> AuthResult
-> Wai.Request -> Wai.Request
-> Handler IO Wai.Response -> ExceptT Error IO Wai.Response
postgrestResponse appState conf@AppConfig{..} maybeSchemaCache authResult@AuthResult{..} req = do postgrestResponse appState conf@AppConfig{..} maybeSchemaCache jwtTime authResult@AuthResult{..} req = do
let observer = AppState.getObserver appState let observer = AppState.getObserver appState
sCache <- sCache <-
@@ -174,20 +183,18 @@ postgrestResponse appState conf@AppConfig{..} maybeSchemaCache authResult@AuthRe
lift $ observer SchemaCacheEmptyObs lift $ observer SchemaCacheEmptyObs
throwError Error.NoSchemaCacheError throwError Error.NoSchemaCacheError
let prefs = ApiRequest.userPreferences conf req (dbTimezones sCache)
body <- lift $ Wai.strictRequestBody req body <- lift $ Wai.strictRequestBody req
let jwtTime = if configServerTimingEnabled then Auth.getJwtDur req else Nothing (parseTime, apiReq@ApiRequest{..}) <- withTiming conf $ liftEither . mapLeft Error.ApiRequestErr $ ApiRequest.userApiRequest conf prefs req body
timezones = dbTimezones sCache (planTime, plan) <- withTiming conf $ liftEither $ Plan.actionPlan iAction conf apiReq sCache
prefs = ApiRequest.userPreferences conf req timezones
(parseTime, apiReq@ApiRequest{..}) <- withTiming $ liftEither . mapLeft Error.ApiRequestErr $ ApiRequest.userApiRequest conf prefs req body
(planTime, plan) <- withTiming $ liftEither $ Plan.actionPlan iAction conf apiReq sCache
let mainQ = Query.mainQuery plan conf apiReq authResult configDbPreRequest let mainQ = Query.mainQuery plan conf apiReq authResult configDbPreRequest
tx = MainTx.mainTx mainQ conf authResult apiReq plan sCache tx = MainTx.mainTx mainQ conf authResult apiReq plan sCache
obsQuery s = when configLogQuery $ observer $ QueryObs mainQ s obsQuery s = when configLogQuery $ observer $ QueryObs mainQ s
(txTime, txResult) <- withTiming $ do (txTime, txResult) <- withTiming conf $ do
case tx of case tx of
MainTx.NoDbTx r -> pure r MainTx.NoDbTx r -> pure r
MainTx.DbTx{..} -> do MainTx.DbTx{..} -> do
@@ -200,7 +207,7 @@ postgrestResponse appState conf@AppConfig{..} maybeSchemaCache authResult@AuthRe
lift $ whenLeft eitherResp $ obsQuery . Error.status lift $ whenLeft eitherResp $ obsQuery . Error.status
liftEither eitherResp liftEither eitherResp
(respTime, resp) <- withTiming $ do (respTime, resp) <- withTiming conf $ do
let response = Response.actionResponse txResult apiReq (T.decodeUtf8 prettyVersion, docsVersion) conf sCache let response = Response.actionResponse txResult apiReq (T.decodeUtf8 prettyVersion, docsVersion) conf sCache
status' = either Error.status Response.pgrstStatus response status' = either Error.status Response.pgrstStatus response
@@ -224,8 +231,8 @@ postgrestResponse appState conf@AppConfig{..} maybeSchemaCache authResult@AuthRe
varyHeaderPresent :: [HTTP.Header] -> Bool varyHeaderPresent :: [HTTP.Header] -> Bool
varyHeaderPresent = any (\(h, _v) -> h == HTTP.hVary) varyHeaderPresent = any (\(h, _v) -> h == HTTP.hVary)
withTiming :: Handler IO a -> Handler IO (Maybe Double, a) withTiming :: AppConfig -> ExceptT e IO a -> ExceptT e IO (Maybe Double, a)
withTiming f = if configServerTimingEnabled withTiming AppConfig{configServerTimingEnabled} f = if configServerTimingEnabled
then do then do
(t, r) <- timeItT f (t, r) <- timeItT f
pure (Just t, r) pure (Just t, r)
+14 -53
View File
@@ -1,4 +1,3 @@
{-# LANGUAGE RecordWildCards #-}
{-| {-|
Module : PostgREST.Auth Module : PostgREST.Auth
Description : PostgREST authentication functions. Description : PostgREST authentication functions.
@@ -12,66 +11,28 @@ In the test suite there is an example of simple login function that can be used
very simple authentication system inside the PostgreSQL database. very simple authentication system inside the PostgreSQL database.
-} -}
module PostgREST.Auth module PostgREST.Auth
( getResult ( getAuthResult )
, getJwtDur where
, getRole
, middleware
) where
import qualified Data.ByteString as BS
import qualified Data.Vault.Lazy as Vault
import qualified Network.HTTP.Types.Header as HTTP
import qualified Network.Wai as Wai
import qualified Network.Wai.Middleware.HttpAuth as Wai
import Data.List (lookup)
import PostgREST.TimeIt (timeItT)
import System.IO.Unsafe (unsafePerformIO)
import PostgREST.AppState (AppState, getConfig, getJwtCacheState, import PostgREST.AppState (AppState, getConfig, getJwtCacheState,
getTime) getTime)
import PostgREST.Auth.Jwt (parseClaims) import PostgREST.Auth.Jwt (parseClaims)
import PostgREST.Auth.JwtCache (lookupJwtCache) import PostgREST.Auth.JwtCache (lookupJwtCache)
import PostgREST.Auth.Types (AuthResult (..)) import PostgREST.Auth.Types (AuthResult)
import PostgREST.Config (AppConfig (..)) import PostgREST.Error (Error)
import PostgREST.Error (Error (..))
import Protolude import Protolude
-- | Validate authorization header -- | Perform authentication and authorization
-- Parse and store JWT claims for future use in the request. -- Parse JWT and return AuthResult
middleware :: AppState -> Wai.Middleware getAuthResult :: AppState -> Maybe ByteString -> IO (Either Error AuthResult)
middleware appState app req respond = do getAuthResult appState token = do
conf@AppConfig{..} <- getConfig appState conf <- getConfig appState
time <- getTime appState time <- getTime appState
let token = Wai.extractBearerAuth =<< lookup HTTP.hAuthorization (Wai.requestHeaders req) let jwtCacheState = getJwtCacheState appState
parseJwt = runExceptT $ lookupJwtCache jwtCacheState token >>= parseClaims conf time parseJwt = runExceptT $ do
jwtCacheState = getJwtCacheState appState claims <- lookupJwtCache jwtCacheState token
parseClaims conf time claims
-- If ServerTimingEnabled -> calculate JWT validation time parseJwt
req' <- if configServerTimingEnabled then do
(dur, authResult) <- timeItT parseJwt
pure $ req { Wai.vault = Wai.vault req & Vault.insert authResultKey authResult & Vault.insert jwtDurKey dur }
else do
authResult <- parseJwt
pure $ req { Wai.vault = Wai.vault req & Vault.insert authResultKey authResult }
app req' respond
authResultKey :: Vault.Key (Either Error AuthResult)
authResultKey = unsafePerformIO Vault.newKey
{-# NOINLINE authResultKey #-}
getResult :: Wai.Request -> Maybe (Either Error AuthResult)
getResult = Vault.lookup authResultKey . Wai.vault
jwtDurKey :: Vault.Key Double
jwtDurKey = unsafePerformIO Vault.newKey
{-# NOINLINE jwtDurKey #-}
getJwtDur :: Wai.Request -> Maybe Double
getJwtDur = Vault.lookup jwtDurKey . Wai.vault
getRole :: Wai.Request -> Maybe BS.ByteString
getRole req = authRole <$> (rightToMaybe =<< getResult req)
+13 -21
View File
@@ -7,8 +7,7 @@ Description : Logging based on the Observation.hs module. Access logs get sent t
-} -}
-- TODO log with buffering enabled to not lose throughput on logging levels higher than LogError -- TODO log with buffering enabled to not lose throughput on logging levels higher than LogError
module PostgREST.Logger module PostgREST.Logger
( middleware (observationLogger
, observationLogger
, init , init
, LoggerState , LoggerState
) where ) where
@@ -26,14 +25,11 @@ import qualified Hasql.Statement as SQL
import Data.Time (ZonedTime, defaultTimeLocale, formatTime, import Data.Time (ZonedTime, defaultTimeLocale, formatTime,
getZonedTime) getZonedTime)
import qualified Network.Wai as Wai
import qualified Network.Wai.Middleware.RequestLogger as Wai
import Network.HTTP.Types.Status (Status, status400, status500) import Network.HTTP.Types.Status (Status, status400, status500)
import System.IO.Unsafe (unsafePerformIO)
import PostgREST.Config (LogLevel (..), Verbosity (..)) import PostgREST.Config (LogLevel (..), Verbosity (..))
import PostgREST.Debounce (makeDebouncer) import PostgREST.Debounce (makeDebouncer)
import PostgREST.Logger.Apache (apacheFormat)
import PostgREST.Observation import PostgREST.Observation
import PostgREST.Query (MainQuery (..)) import PostgREST.Query (MainQuery (..))
import PostgREST.SchemaCache (queryTimingsWLabels) import PostgREST.SchemaCache (queryTimingsWLabels)
@@ -63,20 +59,6 @@ init = mdo
logWithZTime loggerState (observationMessages PoolAcqTimeoutObs) *> threadDelay (5 * oneSecond) logWithZTime loggerState (observationMessages PoolAcqTimeoutObs) *> threadDelay (5 * oneSecond)
pure loggerState pure loggerState
-- TODO stop using this middleware to reuse the same "observer" pattern for all our logs
middleware :: LogLevel -> (Wai.Request -> Maybe BS.ByteString) -> Wai.Middleware
middleware logLevel getAuthRole =
unsafePerformIO $
Wai.mkRequestLogger Wai.defaultRequestLoggerSettings
{ Wai.outputFormat =
Wai.ApacheWithSettings $
Wai.defaultApacheSettings &
Wai.setApacheRequestFilter (\_ res -> shouldLogResponse logLevel $ Wai.responseStatus res) &
Wai.setApacheUserGetter getAuthRole
, Wai.autoFlush = True
, Wai.destination = Wai.Handle stdout
}
shouldLogResponse :: LogLevel -> Status -> Bool shouldLogResponse :: LogLevel -> Status -> Bool
shouldLogResponse logLevel = case logLevel of shouldLogResponse logLevel = case logLevel of
LogCrit -> const False LogCrit -> const False
@@ -109,6 +91,10 @@ observationLogger loggerState logLevel obs = case obs of
o@PoolRequestFullfilled -> o@PoolRequestFullfilled ->
when (logLevel >= LogDebug) $ do when (logLevel >= LogDebug) $ do
logWithZTime loggerState $ observationMessages o logWithZTime loggerState $ observationMessages o
ResponseObs maybeRole req status contentLen ->
when (shouldLogResponse logLevel status) $ do
zTime <- stateGetZTime loggerState
putStr $ apacheFormat maybeRole (BS.pack $ formatZonedTime zTime) req status contentLen -- putStr prints to stdout
o@PoolFlushed -> o@PoolFlushed ->
when (logLevel >= LogDebug) $ do when (logLevel >= LogDebug) $ do
logWithZTime loggerState $ observationMessages o logWithZTime loggerState $ observationMessages o
@@ -127,7 +113,11 @@ observationLogger loggerState logLevel obs = case obs of
logWithZTime :: LoggerState -> [Text] -> IO () logWithZTime :: LoggerState -> [Text] -> IO ()
logWithZTime loggerState txts = do logWithZTime loggerState txts = do
zTime <- stateGetZTime loggerState zTime <- stateGetZTime loggerState
traverse_ (hPutStrLn stderr . (toS (formatTime defaultTimeLocale "%d/%b/%Y:%T %z: " zTime) <>)) txts let prefix = toS (formatZonedTime zTime) <> ": "
traverse_ (hPutStrLn stderr . (prefix <>)) txts
formatZonedTime :: ZonedTime -> [Char]
formatZonedTime = formatTime defaultTimeLocale "%d/%b/%Y:%T %z"
-- TODO: maybe patch upstream hasql-dynamic-statements so we have a less hackish way to convert -- TODO: maybe patch upstream hasql-dynamic-statements so we have a less hackish way to convert
-- the SQL.Snippet or maybe don't use hasql-dynamic-statements and resort to plain strings for the queries and use regular hasql -- the SQL.Snippet or maybe don't use hasql-dynamic-statements and resort to plain strings for the queries and use regular hasql
@@ -243,6 +233,8 @@ observationMessages = \case
pure $ "Received termination unix signal " <> signal pure $ "Received termination unix signal " <> signal
WarpServerObs txt -> WarpServerObs txt ->
pure $ "Warp server: " <> txt pure $ "Warp server: " <> txt
ResponseObs {} ->
mempty -- TODO this message is produced on observationLogger since it depends on Logger state. Merge observationMessages with observationLogger to clear this.
where where
showMillis :: Double -> Text showMillis :: Double -> Text
showMillis x = toS $ showFFloat (Just 1) x "" showMillis x = toS $ showFFloat (Just 1) x ""
+48
View File
@@ -0,0 +1,48 @@
module PostgREST.Logger.Apache
( apacheFormat
) where
import qualified Data.ByteString.Char8 as BS
import Network.Wai.Logger
import System.Log.FastLogger
import Network.HTTP.Types.Status (Status, statusCode)
import Network.Wai
import Protolude
apacheFormat :: ToLogStr user => Maybe user -> FormattedTime -> Request -> Status -> Maybe Integer -> ByteString
apacheFormat maybeUser tmstr req status msize =
fromLogStr $ apacheLogStr maybeUser tmstr req status msize
-- This code is vendored from
-- https://github.com/kazu-yamamoto/logger/blob/57bc4d3b26ca094fd0c3a8a8bb4421bcdcdd7061/wai-logger/Network/Wai/Logger/Apache.hs#L44-L45
apacheLogStr :: ToLogStr user => Maybe user -> FormattedTime -> Request -> Status -> Maybe Integer -> LogStr
apacheLogStr maybeUser tmstr req status msize =
toLogStr (getSourceFromSocket req)
<> " - "
<> maybe "-" toLogStr maybeUser
<> " ["
<> toLogStr tmstr
<> "] \""
<> toLogStr (requestMethod req)
<> " "
<> toLogStr path
<> " "
<> toLogStr (show (httpVersion req)::Text)
<> "\" "
<> toLogStr (show (statusCode status)::Text)
<> " "
<> toLogStr (maybe "-" show msize::Text)
<> " \""
<> toLogStr (fromMaybe "" mr)
<> "\" \""
<> toLogStr (fromMaybe "" mua)
<> "\"\n"
where
path = rawPathInfo req <> rawQueryString req
mr = requestHeaderReferer req
mua = requestHeaderUserAgent req
getSourceFromSocket :: Request -> ByteString
getSourceFromSocket = BS.pack . showSockAddr . remoteHost
+2
View File
@@ -16,6 +16,7 @@ import qualified Hasql.Connection as SQL
import qualified Hasql.Pool as SQL import qualified Hasql.Pool as SQL
import qualified Hasql.Pool.Observation as SQL import qualified Hasql.Pool.Observation as SQL
import Network.HTTP.Types.Status (Status) import Network.HTTP.Types.Status (Status)
import qualified Network.Wai as Wai
import PostgREST.Config.PgVersion import PostgREST.Config.PgVersion
import PostgREST.Query (MainQuery) import PostgREST.Query (MainQuery)
import PostgREST.SchemaCache (QueryTimings) import PostgREST.SchemaCache (QueryTimings)
@@ -52,6 +53,7 @@ data Observation
| PoolInit Int | PoolInit Int
| PoolAcqTimeoutObs | PoolAcqTimeoutObs
| HasqlPoolObs SQL.Observation | HasqlPoolObs SQL.Observation
| ResponseObs (Maybe ByteString) Wai.Request Status (Maybe Integer)
| PoolRequest | PoolRequest
| PoolRequestFullfilled | PoolRequestFullfilled
| PoolFlushed | PoolFlushed
+1 -1
View File
@@ -58,7 +58,7 @@ main = do
appState <- AppState.initWithPool pool config loggerState metricsState (Metrics.observationMetrics metricsState <> writeChan obsChan) appState <- AppState.initWithPool pool config loggerState metricsState (Metrics.observationMetrics metricsState <> writeChan obsChan)
AppState.putPgVersion appState actualPgVersion AppState.putPgVersion appState actualPgVersion
AppState.putSchemaCache appState (Just sCache) AppState.putSchemaCache appState (Just sCache)
return (SpecState appState metricsState stateObsChan, postgrest (configLogLevel config) appState (pure ())) return (SpecState appState metricsState stateObsChan, postgrest appState (pure ()))
-- Run all test modules -- Run all test modules
hspec $ do hspec $ do
+4 -4
View File
@@ -90,19 +90,19 @@ main = do
metricsState <- Metrics.init (configDbPoolSize testCfg) metricsState <- Metrics.init (configDbPoolSize testCfg)
let let
initApp sCache st config = do initApp sCache config = do
appState <- AppState.initWithPool pool config loggerState metricsState (Metrics.observationMetrics metricsState) appState <- AppState.initWithPool pool config loggerState metricsState (Metrics.observationMetrics metricsState)
AppState.putPgVersion appState actualPgVersion AppState.putPgVersion appState actualPgVersion
AppState.putSchemaCache appState (Just sCache) AppState.putSchemaCache appState (Just sCache)
return (st, postgrest (configLogLevel config) appState (pure ())) return ((), postgrest appState (pure ()))
-- For tests that run with the same schema cache -- For tests that run with the same schema cache
app = initApp baseSchemaCache () app = initApp baseSchemaCache
-- 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 <- loadSCache pool config customSchemaCache <- loadSCache pool config
initApp customSchemaCache () config initApp customSchemaCache config
let withApp = app testCfg let withApp = app testCfg
maxRowsApp = app testMaxRowsCfg maxRowsApp = app testMaxRowsCfg