refactor: complete purifying Response module

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

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)] ++))