Allow returning XML from RPCs

CHANGELOG.md

@@ -26,6 +26,7 @@ This project adheres to [Semantic Versioning](http://semver.org/).
  - #1917, Normalize the error response body by always having the `detail` and `hint` error fields with a `null` value if they are empty - @laurenceisla
  - #2176, Errors raised with `SQLSTATE` now include the message and the code in the response body - @laurenceisla
  - #2236, Support POSIX regular expression operators for row filtering - @enote-kane
+ - #2202, Allow returning XML from RPCs - @fjf2002
 
 ### Fixed
 

src/PostgREST/App.hs

@@ -466,6 +466,7 @@ handleInvoke invMethod proc context@RequestContext{..} = do
         (shouldCount iPreferCount)
         (iAcceptContentType == CTSingularJSON)
         (iAcceptContentType == CTTextCSV)
+        (iAcceptContentType == CTTextXML)
         (iPreferParameters == Just MultipleObjects)
         bField
         (configDbPreparedStatements ctxConfig)
@@ -623,7 +624,7 @@ binaryField RequestContext{..} readReq
 
 rawContentTypes :: AppConfig -> [ContentType]
 rawContentTypes AppConfig{..} =
-  (ContentType.decodeContentType <$> configRawMediaTypes) `union` [CTOctetStream, CTTextPlain]
+  (ContentType.decodeContentType <$> configRawMediaTypes) `union` [CTOctetStream, CTTextPlain, CTTextXML]
 
 profileHeader :: ApiRequest -> Maybe HTTP.Header
 profileHeader ApiRequest{..} =

src/PostgREST/ContentType.hs

@@ -20,6 +20,7 @@ data ContentType
   | CTSingularJSON
   | CTTextCSV
   | CTTextPlain
+  | CTTextXML
   | CTOpenAPI
   | CTUrlEncoded
   | CTOctetStream
@@ -41,6 +42,7 @@ toMime :: ContentType -> ByteString
 toMime CTApplicationJSON = "application/json"
 toMime CTTextCSV         = "text/csv"
 toMime CTTextPlain       = "text/plain"
+toMime CTTextXML         = "text/xml"
 toMime CTOpenAPI         = "application/openapi+json"
 toMime CTSingularJSON    = "application/vnd.pgrst.object+json"
 toMime CTUrlEncoded      = "application/x-www-form-urlencoded"
@@ -55,6 +57,7 @@ decodeContentType ct =
     "application/json"                  -> CTApplicationJSON
     "text/csv"                          -> CTTextCSV
     "text/plain"                        -> CTTextPlain
+    "text/xml"                          -> CTTextXML
     "application/openapi+json"          -> CTOpenAPI
     "application/vnd.pgrst.object+json" -> CTSingularJSON
     "application/vnd.pgrst.object"      -> CTSingularJSON

src/PostgREST/Error.hs

@@ -271,7 +271,9 @@ pgErrorStatus authed (SQL.SessionError (SQL.QueryError _ _ (SQL.ResultError rErr
         "P0001"   -> HTTP.status400 -- default code for "raise"
         'P':'0':_ -> HTTP.status500 -- PL/pgSQL Error
         'X':'X':_ -> HTTP.status500 -- internal Error
-        "42883"   -> HTTP.status404 -- undefined function
+        "42883"-> if BS.isPrefixOf "function xmlagg(" m
+          then HTTP.status406
+          else HTTP.status404 -- undefined function
         "42P01"   -> HTTP.status404 -- undefined table
         "42501"   -> if authed then HTTP.status403 else HTTP.status401 -- insufficient privilege
         'P':'T':n -> fromMaybe HTTP.status500 (HTTP.mkStatus <$> readMaybe n <*> pure m)

src/PostgREST/Query/SqlFragment.hs

@@ -13,6 +13,7 @@ module PostgREST.Query.SqlFragment
   , asCsvF
   , asJsonF
   , asJsonSingleF
+  , asXmlF
   , countF
   , fromQi
   , limitOffsetF
@@ -176,6 +177,9 @@ asJsonSingleF returnsScalar
   | returnsScalar = "coalesce((json_agg(_postgrest_t.pgrst_scalar)->0)::text, 'null')"
   | otherwise     = "coalesce((json_agg(_postgrest_t)->0)::text, 'null')"
 
+asXmlF :: FieldName -> SqlFragment
+asXmlF fieldName = "coalesce(xmlagg(_postgrest_t." <> pgFmtIdent fieldName <> "), '')"
+
 asBinaryF :: FieldName -> SqlFragment
 asBinaryF fieldName = "coalesce(string_agg(_postgrest_t." <> pgFmtIdent fieldName <> ", ''), '')"
 

src/PostgREST/Query/Statements.hs

@@ -129,9 +129,9 @@ standardRow = (,,,,,) <$> nullableColumn HD.int8 <*> column HD.int8
 type ProcResults = (Maybe Int64, Int64, ByteString, Either Error [GucHeader], Either Error (Maybe Status))
 
 callProcStatement :: Bool -> Bool -> SQL.Snippet -> SQL.Snippet -> SQL.Snippet -> Bool ->
-                     Bool -> Bool -> Bool -> Maybe FieldName -> Bool ->
+                     Bool -> Bool -> Bool -> Bool -> Maybe FieldName -> Bool ->
                      SQL.Statement () ProcResults
-callProcStatement returnsScalar returnsSingle callProcQuery selectQuery countQuery countTotal asSingle asCsv multObjects binaryField =
+callProcStatement returnsScalar returnsSingle callProcQuery selectQuery countQuery countTotal asSingle asCsv asXml multObjects binaryField =
   SQL.dynamicallyParameterized snippet decodeProc
   where
     snippet =
@@ -151,6 +151,7 @@ callProcStatement returnsScalar returnsSingle callProcQuery selectQuery countQue
     bodyF
      | asSingle           = asJsonSingleF returnsScalar
      | asCsv              = asCsvF
+     | isJust binaryField && asXml = asXmlF $ fromJust binaryField
      | isJust binaryField = asBinaryF $ fromJust binaryField
      | returnsSingle
        && not multObjects = asJsonSingleF returnsScalar

src/PostgREST/Request/ApiRequest.hs

@@ -421,7 +421,7 @@ requestContentTypes conf action path =
 
 rawContentTypes :: AppConfig -> [ContentType]
 rawContentTypes AppConfig{..} =
-  (ContentType.decodeContentType <$> configRawMediaTypes) `union` [CTOctetStream, CTTextPlain]
+  (ContentType.decodeContentType <$> configRawMediaTypes) `union` [CTOctetStream, CTTextPlain, CTTextXML]
 
 {-|
   Search a pg proc by matching name and arguments keys to parameters. Since a function can be overloaded,

test/spec/Feature/Query/RpcSpec.hs

@@ -970,6 +970,37 @@ spec actualPgVersion =
             , matchHeaders = ["Content-Type" <:> "text/plain; charset=utf-8"]
             }
 
+        it "can get raw xml output with Accept: text/xml" $
+          request methodGet "/rpc/return_scalar_xml" (acceptHdrs "text/xml") ""
+            `shouldRespondWith`
+            "<my-xml-tag/>"
+            { matchStatus = 200
+            , matchHeaders = ["Content-Type" <:> "text/xml; charset=utf-8"]
+            }
+
+        it "can get raw xml output with Accept: text/xml" $
+          request methodGet "/rpc/welcome.xml" (acceptHdrs "text/xml") ""
+            `shouldRespondWith`
+            "<html>\n  <head>\n    <title>PostgREST</title>\n  </head>\n  <body>\n    <h1>Welcome to PostgREST</h1>\n  </body>\n</html>"
+            { matchStatus = 200
+            , matchHeaders = ["Content-Type" <:> "text/xml; charset=utf-8"]
+            }
+
+        it "should fail with function returning text and Accept: text/xml" $
+          request methodGet "/rpc/welcome" (acceptHdrs "text/xml") ""
+            `shouldRespondWith`
+            [json|
+              {
+                "hint":"No function matches the given name and argument types. You might need to add explicit type casts.",
+                "details":null,
+                "code":"42883",
+                "message":"function xmlagg(text) does not exist"
+              }
+            |]
+            { matchStatus = 406
+            , matchHeaders = ["Content-Type" <:> "application/json; charset=utf-8"]
+            }
+
       context "Proc that returns set of scalars" $
         it "can query without selecting column" $
           request methodGet "/rpc/welcome_twice"

test/spec/fixtures/schema.sql

@@ -2553,3 +2553,21 @@ create table plate_plan_step (
       FOREIGN KEY(to_well_id)
 	  REFERENCES well(well_id)
 );
+
+CREATE FUNCTION test.return_scalar_xml() RETURNS pg_catalog.xml
+LANGUAGE sql AS $$
+  SELECT '<my-xml-tag/>'::pg_catalog.xml
+$$;
+
+CREATE OR REPLACE FUNCTION "welcome.xml"() RETURNS pg_catalog.xml
+LANGUAGE sql AS $_$
+select $$
+<html>
+  <head>
+    <title>PostgREST</title>
+  </head>
+  <body>
+    <h1>Welcome to PostgREST</h1>
+  </body>
+</html>$$::pg_catalog.xml;
+$_$;