Allow overriding headers Location,Content-Type,etc

CHANGELOG.md

@@ -16,6 +16,7 @@ This project adheres to [Semantic Versioning](http://semver.org/).
 - #1168, Allow access to the `Authorization` header through the `request.header.authorization` GUC - @steve-chavez
 - #1435, Add `request.method` and `request.path` GUCs - @steve-chavez
 - #1088, Allow adding headers to GET/POST/PATCH/PUT/DELETE responses through the `response.headers` GUC - @steve-chavez
+- #1427, Allow overriding provided headers(Location, Content-Type, etc) through the `response.headers` GUC - @steve-chavez
 
 ### Fixed
 

src/PostgREST/App.hs

@@ -137,20 +137,22 @@ app dbStructure proc cols conf apiRequest =
               let (tableTotal, queryTotal, _ , body, gucHeaders) = row
               case gucHeaders of
                 Left _ -> return . errorResponseFor $ GucHeadersError
-                Right hs -> do
+                Right ghdrs -> do
                   total <- if | plannedCount   -> H.statement () explStm
                               | estimatedCount -> if tableTotal > (fromIntegral <$> maxRows)
                                                     then do estTotal <- H.statement () explStm
                                                             pure $ if estTotal > tableTotal then estTotal else tableTotal
                                                     else pure tableTotal
                               | otherwise      -> pure tableTotal
                   let (status, contentRange) = rangeStatusHeader topLevelRange queryTotal total
+                      headers = addHeadersIfNotIncluded
+                                [toHeader contentType, contentRange, contentLocationH tName (iCanonicalQS apiRequest)]
+                                (unwrapGucHeader <$> ghdrs)
+                      rBody = if headersOnly then mempty else toS body
                   return $
                     if contentType == CTSingularJSON && queryTotal /= 1
                       then errorResponseFor . singularityError $ queryTotal
-                      else responseLBS status
-                        ([toHeader contentType, contentRange, contentLocationH tName (iCanonicalQS apiRequest)] ++ (gucHToHeader <$> hs))
-                        (if headersOnly then mempty else toS body)
+                      else responseLBS status headers rBody
 
         (ActionCreate, TargetIdent (QualifiedIdentifier tSchema tName), Just pJson) ->
           case mutateSqlParts tSchema tName of
@@ -161,29 +163,28 @@ app dbStructure proc cols conf apiRequest =
                     (contentType == CTSingularJSON) True
                     (contentType == CTTextCSV) (iPreferRepresentation apiRequest) pkCols pgVer
               row <- H.statement (toS $ pjRaw pJson) stm
-              let (_, queryTotal, fs, body, gucHeaders) = row
+              let (_, queryTotal, fields, body, gucHeaders) = row
               case gucHeaders of
                 Left _ -> return . errorResponseFor $ GucHeadersError
-                Right hdrs -> do
-                  let headers = catMaybes [
-                          if null fs
-                            then Nothing
-                            else Just $ locationH tName fs
-                        , if iPreferRepresentation apiRequest == Full
-                            then Just $ toHeader contentType
-                            else Nothing
-                        , Just $ contentRangeH 1 0 $
-                            if shouldCount then Just queryTotal else Nothing
+                Right ghdrs -> do
+                  let
+                    (ctHeader, rBody) = if iPreferRepresentation apiRequest == Full then (toHeader contentType, toS body) else (mempty, mempty)
+                    headers = addHeadersIfNotIncluded [
+                          if null fields
+                            then mempty
+                            else locationH tName fields
+                        , ctHeader
+                        , contentRangeH 1 0 $ if shouldCount then Just queryTotal else Nothing
                         , if null pkCols && isNothing (iOnConflict apiRequest)
-                            then Nothing
-                            else (\x -> ("Preference-Applied", show x)) <$> iPreferResolution apiRequest
-                        ] ++ (gucHToHeader <$> hdrs)
+                            then mempty
+                            else maybe mempty (\x -> ("Preference-Applied", show x)) $ iPreferResolution apiRequest
+                        ] (unwrapGucHeader <$> ghdrs)
                   if contentType == CTSingularJSON && queryTotal /= 1
                     then do
                       HT.condemn
                       return . errorResponseFor . singularityError $ queryTotal
                     else
-                      return . responseLBS status201 headers $ if iPreferRepresentation apiRequest == Full then toS body else mempty
+                      return $ responseLBS status201 headers rBody
 
         (ActionUpdate, TargetIdent (QualifiedIdentifier tSchema tName), Just pJson) ->
           case mutateSqlParts tSchema tName of
@@ -196,22 +197,21 @@ app dbStructure proc cols conf apiRequest =
               let (_, queryTotal, _, body, gucHeaders) = row
               case gucHeaders of
                 Left _ -> return . errorResponseFor $ GucHeadersError
-                Right hdrs -> do
+                Right ghdrs -> do
                   let
                     updateIsNoOp = S.null cols
                     status | queryTotal == 0 && not updateIsNoOp      = status404
                            | iPreferRepresentation apiRequest == Full = status200
                            | otherwise                                = status204
                     contentRangeHeader = contentRangeH 0 (queryTotal - 1) $ if shouldCount then Just queryTotal else Nothing
-                    headers = [contentRangeHeader] ++
-                              [if iPreferRepresentation apiRequest == Full then toHeader contentType else mempty] ++
-                              (gucHToHeader <$> hdrs)
+                    (ctHeader, rBody) = if iPreferRepresentation apiRequest == Full then (toHeader contentType, toS body) else (mempty, mempty)
+                    headers = addHeadersIfNotIncluded [contentRangeHeader, ctHeader] (unwrapGucHeader <$> ghdrs)
                   if contentType == CTSingularJSON && queryTotal /= 1
                     then do
                       HT.condemn
                       return . errorResponseFor . singularityError $ queryTotal
                     else
-                      return . responseLBS status headers $ if iPreferRepresentation apiRequest == Full then toS body else mempty
+                      return $ responseLBS status headers rBody
 
         (ActionSingleUpsert, TargetIdent (QualifiedIdentifier tSchema tName), Just ProcessedJSON{pjRaw, pjType, pjKeys}) ->
           case mutateSqlParts tSchema tName of
@@ -234,9 +234,9 @@ app dbStructure proc cols conf apiRequest =
                 let (_, queryTotal, _, body, gucHeaders) = row
                 case gucHeaders of
                   Left _ -> return . errorResponseFor $ GucHeadersError
-                  Right hdrs -> do
-                    let headers = toHeader contentType : (gucHToHeader <$> hdrs)
-                        status = if iPreferRepresentation apiRequest == Full then status200 else status204
+                  Right ghdrs -> do
+                    let headers = addHeadersIfNotIncluded [toHeader contentType] (unwrapGucHeader <$> ghdrs)
+                        (status, rBody) = if iPreferRepresentation apiRequest == Full then (status200, toS body) else (status204, mempty)
                     -- Makes sure the querystring pk matches the payload pk
                     -- e.g. PUT /items?id=eq.1 { "id" : 1, .. } is accepted, PUT /items?id=eq.14 { "id" : 2, .. } is rejected
                     -- If this condition is not satisfied then nothing is inserted, check the WHERE for INSERT in QueryBuilder.hs to see how it's done
@@ -245,7 +245,7 @@ app dbStructure proc cols conf apiRequest =
                         HT.condemn
                         return . errorResponseFor $ PutMatchingPkError
                       else
-                        return . responseLBS status headers $ if iPreferRepresentation apiRequest == Full then toS body else mempty
+                        return $ responseLBS status headers rBody
 
         (ActionDelete, TargetIdent (QualifiedIdentifier tSchema tName), Nothing) ->
           case mutateSqlParts tSchema tName of
@@ -259,20 +259,19 @@ app dbStructure proc cols conf apiRequest =
               let (_, queryTotal, _, body, gucHeaders) = row
               case gucHeaders of
                 Left _ -> return . errorResponseFor $ GucHeadersError
-                Right hdrs -> do
+                Right ghdrs -> do
                   let
                     status = if iPreferRepresentation apiRequest == Full then status200 else status204
                     contentRangeHeader = contentRangeH 1 0 $ if shouldCount then Just queryTotal else Nothing
-                    headers = [contentRangeHeader] ++
-                              [if iPreferRepresentation apiRequest == Full then toHeader contentType else mempty] ++
-                              (gucHToHeader <$> hdrs)
+                    (ctHeader, rBody) = if iPreferRepresentation apiRequest == Full then (toHeader contentType, toS body) else (mempty, mempty)
+                    headers = addHeadersIfNotIncluded [contentRangeHeader, ctHeader] (unwrapGucHeader <$> ghdrs)
                   if contentType == CTSingularJSON
                      && queryTotal /= 1
                     then do
                       HT.condemn
                       return . errorResponseFor . singularityError $ queryTotal
                     else
-                      return . responseLBS status headers $ if iPreferRepresentation apiRequest == Full then toS body else mempty
+                      return $ responseLBS status headers rBody
 
         (ActionInfo, TargetIdent (QualifiedIdentifier tSchema tTable), Nothing) ->
           let mTable = find (\t -> tableName t == tTable && tableSchema t == tSchema) (dbTables dbStructure) in
@@ -296,17 +295,18 @@ app dbStructure proc cols conf apiRequest =
                         bField pgVer
               row <- H.statement (toS $ pjRaw pJson) stm
               let (tableTotal, queryTotal, body, gucHeaders) = row
-                  (status, contentRange) = rangeStatusHeader topLevelRange queryTotal tableTotal
               case gucHeaders of
                 Left _ -> return . errorResponseFor $ GucHeadersError
-                Right hs ->
+                Right ghdrs -> do
+                  let (status, contentRange) = rangeStatusHeader topLevelRange queryTotal tableTotal
+                      headers = addHeadersIfNotIncluded [toHeader contentType, contentRange] (unwrapGucHeader <$> ghdrs)
+                      rBody = if invMethod == InvHead then mempty else toS body
                   if contentType == CTSingularJSON && queryTotal /= 1
                     then do
                       HT.condemn
                       return . errorResponseFor . singularityError $ queryTotal
                     else
-                      return $ responseLBS status ([toHeader contentType, contentRange] ++ (gucHToHeader <$> hs))
-                      (if invMethod == InvHead then mempty else toS body)
+                      return $ responseLBS status headers rBody
 
         (ActionInspect headersOnly, TargetDefaultSpec tSchema, Nothing) -> do
           let host = configHost conf
@@ -395,7 +395,7 @@ binaryField ct rawContentTypes isScalarProc readReq
 locationH :: TableName -> [BS.ByteString] -> Header
 locationH tName fields =
   let
-    locationFields = renderSimpleQuery True $ map splitKeyValue fields
+    locationFields = renderSimpleQuery True $ splitKeyValue <$> fields
   in
     (hLocation, "/" <> toS tName <> locationFields)
   where

src/PostgREST/Types.hs

@@ -399,17 +399,24 @@ type RpcQParam = (Text, Text)
   Custom guc header, it's obtained by parsing the json in a:
   `SET LOCAL "response.headers" = '[{"Set-Cookie": ".."}]'
 -}
-newtype GucHeader = GucHeader (Text, Text)
+newtype GucHeader = GucHeader (CI.CI ByteString, ByteString)
+  deriving (Show, Eq)
 
 instance JSON.FromJSON GucHeader where
   parseJSON (JSON.Object o) = case headMay (M.toList o) of
-    Just (k, JSON.String s) | M.size o == 1 -> pure $ GucHeader (k, s)
+    Just (k, JSON.String s) | M.size o == 1 -> pure $ GucHeader (CI.mk $ toS k, toS s)
                             | otherwise     -> mzero
     _ -> mzero
   parseJSON _          = mzero
 
-gucHToHeader :: GucHeader -> Header
-gucHToHeader (GucHeader (k, v)) = (CI.mk $ toS k, toS v)
+unwrapGucHeader :: GucHeader -> Header
+unwrapGucHeader (GucHeader (k, v)) = (k, v)
+
+-- | Add headers not already included to allow the user to override them instead of duplicating them
+addHeadersIfNotIncluded :: [Header] -> [Header] -> [Header]
+addHeadersIfNotIncluded newHeaders initialHeaders =
+  filter (\(nk, _) -> isNothing $ find (\(ik, _) -> ik == nk) initialHeaders) newHeaders ++
+  initialHeaders
 
 {-|
   This type will hold information about which particular 'Relation' between two tables to choose when there are multiple ones.

test/Feature/PgVersion96Spec.hs

@@ -112,6 +112,26 @@ spec =
           , matchHeaders = ["X-Custom-Header" <:> "mykey=myval"]
           }
 
+    context "Override provided headers by using GUC headers" $ do
+      it "can override the Content-Type header" $ do
+        request methodHead "/clients?id=eq.1" [] mempty
+          `shouldRespondWith` ""
+          { matchStatus = 200
+          , matchHeaders = ["Content-Type" <:> "application/geo+json"]
+          }
+        request methodHead "/rpc/getallprojects" [] mempty
+          `shouldRespondWith` ""
+          { matchStatus = 200
+          , matchHeaders = ["Content-Type" <:> "application/geo+json"]
+          }
+
+      it "can override the Location header" $
+        request methodPost "/stuff" [] [json|[{"id": 1, "name": "stuff 1"}]|]
+          `shouldRespondWith` ""
+          { matchStatus = 201
+          , matchHeaders = ["Location" <:> "/stuff?id=eq.1&overriden=true"]
+          }
+
     context "Use of the phraseto_tsquery function" $ do
       it "finds matches" $
         get "/tsearch?text_search_vector=phfts.The%20Fat%20Cats" `shouldRespondWith`

test/fixtures/privileges.sql

@@ -120,6 +120,7 @@ GRANT ALL ON TABLE
     , schedules
     , activities
     , unit_workdays
+    , stuff
 TO postgrest_test_anonymous;
 
 GRANT INSERT ON TABLE insertonly TO postgrest_test_anonymous;

test/fixtures/schema.sql

@@ -1656,8 +1656,35 @@ begin
   elsif req_path similar to '/(items|projects)' and req_accept = 'text/csv' then
     perform set_config('response.headers',
       format('[{"Content-Disposition": "attachment; filename=%s.csv"}]', trim('/' from req_path)), false);
+  elsif req_path similar to '/(clients|rpc/getallprojects)' then
+    perform set_config('response.headers',
+      '[{"Content-Type": "application/geo+json"}]', false);
   else
     perform set_config('response.headers',
       '[{"X-Custom-Header": "mykey=myval"}]', false);
   end if;
 end; $$ language plpgsql;
+
+create table private.stuff(
+  id integer primary key
+, name text
+);
+
+create view test.stuff as select * from private.stuff;
+
+create or replace function location_for_stuff() returns trigger
+    as $$
+begin
+    insert into private.stuff values (new.id, new.name);
+    if new.id is not null
+    then
+      perform set_config(
+        'response.headers'
+      , format('[{"Location": "/%s?id=eq.%s&overriden=true"}]', tg_table_name, new.id)
+      , false
+      );
+    end if;
+    return new;
+end
+$$ language plpgsql security definer;
+create trigger location_for_stuff instead of insert on test.stuff for each row execute procedure test.location_for_stuff();