diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 9f014c003..aed65e889 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -9,6 +9,7 @@ Some of its functionality includes: - Producing HTTP Headers according to RFCs. - Content Negotiation -} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} module PostgREST.App ( SignalHandlerInstaller @@ -57,7 +58,10 @@ import PostgREST.SchemaCache (SchemaCache (..)) import PostgREST.SchemaCache.Routine (Routine (..)) import PostgREST.Version (docsVersion, prettyVersion) -import Protolude hiding (Handler) +import qualified Data.ByteString.Char8 as BS +import qualified Data.List as L +import qualified Network.HTTP.Types as HTTP +import Protolude hiding (Handler) type Handler = ExceptT Error @@ -101,7 +105,7 @@ serverSettings AppConfig{..} = -- | PostgREST application postgrest :: AppConfig -> AppState.AppState -> IO () -> Wai.Application postgrest conf appState connWorker = - Response.traceHeaderMiddleware conf . + traceHeaderMiddleware conf . Cors.middleware . Auth.middleware appState . Logger.middleware (configLogLevel conf) $ @@ -123,10 +127,10 @@ postgrest conf appState connWorker = -- Launch the connWorker when the connection is down. The postgrest -- function can respond successfully (with a stale schema cache) before -- the connWorker is done. - when (Response.isServiceUnavailable response) connWorker + when (isServiceUnavailable response) connWorker resp <- do delay <- AppState.getRetryNextIn appState - return $ Response.addRetryHint delay response + return $ addRetryHint delay response respond resp postgrestResponse @@ -239,3 +243,19 @@ handleRequest AuthResult{..} conf appState authenticated prepared pgVer apiReq@A pgrstResponse :: Response.PgrstResponse -> Wai.Response pgrstResponse (Response.PgrstResponse st hdrs bod) = Wai.responseLBS st hdrs bod + +traceHeaderMiddleware :: AppConfig -> Wai.Middleware +traceHeaderMiddleware AppConfig{configServerTraceHeader} app req respond = + case configServerTraceHeader of + Nothing -> app req respond + Just hdr -> + let hdrVal = L.lookup hdr $ Wai.requestHeaders req in + app req (respond . Wai.mapResponseHeaders ([(hdr, fromMaybe mempty hdrVal)] ++)) + +addRetryHint :: Int -> Wai.Response -> Wai.Response +addRetryHint delay response = do + let h = ("Retry-After", BS.pack $ show delay) + Wai.mapResponseHeaders (\hs -> if isServiceUnavailable response then h:hs else hs) response + +isServiceUnavailable :: Wai.Response -> Bool +isServiceUnavailable response = Wai.responseStatus response == HTTP.status503 diff --git a/src/PostgREST/Response.hs b/src/PostgREST/Response.hs index 77ecc385e..24b3f5481 100644 --- a/src/PostgREST/Response.hs +++ b/src/PostgREST/Response.hs @@ -15,9 +15,6 @@ module PostgREST.Response , readResponse , singleUpsertResponse , updateResponse - , addRetryHint - , isServiceUnavailable - , traceHeaderMiddleware , ServerTimingParams(..) , PgrstResponse(..) ) where @@ -26,12 +23,10 @@ import qualified Data.Aeson as JSON import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.HashMap.Strict as HM -import qualified Data.List as L import Data.Text.Read (decimal) import qualified Network.HTTP.Types.Header as HTTP import qualified Network.HTTP.Types.Status as HTTP import qualified Network.HTTP.Types.URI as HTTP -import qualified Network.Wai as Wai import Numeric (showFFloat) import qualified PostgREST.Error as Error @@ -301,14 +296,6 @@ profileHeader schema negotiatedByProfile = else Nothing -addRetryHint :: Int -> Wai.Response -> Wai.Response -addRetryHint delay response = do - let h = ("Retry-After", BS.pack $ show delay) - Wai.mapResponseHeaders (\hs -> if isServiceUnavailable response then h:hs else hs) response - -isServiceUnavailable :: Wai.Response -> Bool -isServiceUnavailable response = Wai.responseStatus response == HTTP.status503 - -- | Add headers not already included to allow the user to override them instead of duplicating them addHeadersIfNotIncluded :: [HTTP.Header] -> [HTTP.Header] -> [HTTP.Header] addHeadersIfNotIncluded newHeaders initialHeaders = @@ -326,11 +313,3 @@ addHeadersIfNotIncluded newHeaders initialHeaders = serverTimingHeader :: Maybe ServerTimingParams -> [HTTP.Header] serverTimingHeader (Just ServerTimingParams{..}) = [("Server-Timing", "jwt;dur=" <> BS.pack (showFFloat (Just 1) (jwtDur*1000000) ""))] serverTimingHeader Nothing = [] - -traceHeaderMiddleware :: AppConfig -> Wai.Middleware -traceHeaderMiddleware AppConfig{configServerTraceHeader} app req respond = - case configServerTraceHeader of - Nothing -> app req respond - Just hdr -> - let hdrVal = L.lookup hdr $ Wai.requestHeaders req in - app req (respond . Wai.mapResponseHeaders ([(hdr, fromMaybe mempty hdrVal)] ++))