Introduced raw-media-types config option (#1349)

* extracted rawOutputTypes to config variable raw-output-media-types

* removed CTTextHtml from Types.hs

CHANGELOG.md

@@ -9,6 +9,8 @@ This project adheres to [Semantic Versioning](http://semver.org/).
 
 ### Added
 
+- #1349, Add user defined raw output media types via `raw-media-types` config option
+
 ### Fixed
 
 ## [6.0.0] - 2019-06-21
@@ -24,6 +26,7 @@ This project adheres to [Semantic Versioning](http://semver.org/).
 - #790, Allow override of OpenAPI spec through `root-spec` config option - @steve-chavez
 - #1308, Accept `text/plain` and `text/html` for raw output - @steve-chavez
 
+
 ### Fixed
 
 - #1223, Fix incorrect OpenAPI externalDocs url - @steve-chavez

postgrest.cabal

@@ -141,6 +141,8 @@ test-suite spec
                       Feature.StructureSpec
                       Feature.UnicodeSpec
                       Feature.UpsertSpec
+                      Feature.RawOutputTypesSpec
+                      Feature.HtmlRawOutputSpec
                       SpecHelper
                       TestTypes
   hs-source-dirs:     test

src/PostgREST/App.hs

@@ -8,6 +8,7 @@ module PostgREST.App (
 
 import qualified Data.ByteString.Char8      as BS
 import qualified Data.HashMap.Strict        as M
+import qualified Data.List                  as L (union)
 import qualified Data.Set                   as S
 import qualified Hasql.Pool                 as P
 import qualified Hasql.Transaction          as H
@@ -56,7 +57,6 @@ postgrest :: AppConfig -> IORef (Maybe DbStructure) -> P.Pool -> IO UTCTime -> I
 postgrest conf refDbStructure pool getTime worker =
   let middle = (if configQuiet conf then id else logStdout) . defaultMiddle
       jwtSecret = parseSecret <$> configJwtSecret conf in
-
   middle $ \ req respond -> do
     time <- getTime
     body <- strictRequestBody req
@@ -103,14 +103,14 @@ transactionMode proc action =
 
 app :: DbStructure -> Maybe ProcDescription -> S.Set FieldName -> AppConfig -> ApiRequest -> H.Transaction Response
 app dbStructure proc cols conf apiRequest =
-  case responseContentTypeOrError (iAccepts apiRequest) (iAction apiRequest) (iTarget apiRequest) of
+  case responseContentTypeOrError (iAccepts apiRequest) rawContentTypes (iAction apiRequest) (iTarget apiRequest) of
     Left errorResponse -> return errorResponse
     Right contentType ->
       case (iAction apiRequest, iTarget apiRequest, iPayload apiRequest) of
 
         (ActionRead, TargetIdent qi, Nothing) ->
           let partsField = (,) <$> readSqlParts
-                <*> (binaryField contentType =<< fldNames) in
+                <*> (binaryField contentType rawContentTypes =<< fldNames) in
           case partsField of
             Left errorResponse -> return errorResponse
             Right ((q, cq), bField) -> do
@@ -265,7 +265,7 @@ app dbStructure proc cols conf apiRequest =
                 _ -> False
               rpcBinaryField = if returnsScalar
                                  then Right Nothing
-                                 else binaryField contentType =<< fldNames
+                                 else binaryField contentType rawContentTypes =<< fldNames
               parts = (,) <$> readSqlParts <*> rpcBinaryField in
           case parts of
             Left errorResponse -> return errorResponse
@@ -329,17 +329,22 @@ app dbStructure proc cols conf apiRequest =
       mutateSqlParts s t =
         (,) <$> selectQuery
             <*> (requestToQuery schema False . DbMutate <$> mutationDbRequest s t)
+      rawContentTypes =
+        (decodeContentType <$> configRawMediaTypes conf) `L.union`
+        [ CTOctetStream, CTTextPlain ]
 
-responseContentTypeOrError :: [ContentType] -> Action -> Target -> Either Response ContentType
+responseContentTypeOrError :: [ContentType] -> [ContentType] -> Action -> Target -> Either Response ContentType
-responseContentTypeOrError accepts action target = serves contentTypesForRequest accepts
+responseContentTypeOrError accepts rawContentTypes action target = serves contentTypesForRequest accepts
   where
     contentTypesForRequest = case action of
-      ActionRead         ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV] ++ rawContentTypes
+      ActionRead         ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]
+                             ++ rawContentTypes
       ActionCreate       ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]
       ActionUpdate       ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]
       ActionDelete       ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]
-      ActionInvoke _     ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV] ++ rawContentTypes ++
+      ActionInvoke _     ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]
-                             [CTOpenAPI | tpIsRootSpec target]
+                             ++ rawContentTypes
+                             ++ [CTOpenAPI | tpIsRootSpec target]
       ActionInspect      ->  [CTOpenAPI, CTApplicationJSON]
       ActionInfo         ->  [CTTextCSV]
       ActionSingleUpsert ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]
@@ -352,8 +357,8 @@ responseContentTypeOrError accepts action target = serves contentTypesForRequest
   | If raw(binary) output is requested, check that ContentType is one of the admitted rawContentTypes and that
   | `?select=...` contains only one field other than `*`
 -}
-binaryField :: ContentType -> [FieldName] -> Either Response (Maybe FieldName)
+binaryField :: ContentType -> [ContentType]-> [FieldName] -> Either Response (Maybe FieldName)
-binaryField ct fldNames
+binaryField ct rawContentTypes fldNames
   | ct `elem` rawContentTypes =
       let fieldName = headMay fldNames in
       if length fldNames == 1 && fieldName /= Just "*"

src/PostgREST/Config.hs

@@ -88,6 +88,7 @@ data AppConfig = AppConfig {
   , configExtraSearchPath   :: [Text]
 
   , configRootSpec          :: Maybe QualifiedIdentifier
+  , configRawMediaTypes     :: [B.ByteString]
   }
 
 configPoolTimeout' :: (Fractional a) => AppConfig -> a
@@ -168,6 +169,7 @@ readOptions = do
         <*> (maybe (Right [JSPKey "role"]) parseRoleClaimKey <$> optValue "role-claim-key")
         <*> (maybe ["public"] splitExtraSearchPath <$> optValue "db-extra-search-path")
         <*> ((\x y -> QualifiedIdentifier x <$> y) <$> dbSchema <*> optString "root-spec")
+        <*> (fmap encodeUtf8 <$> optionalListOfText "raw-media-types")
 
     parseJwtAudience :: C.Key -> C.Parser C.Config (Maybe StringOrURI)
     parseJwtAudience k =
@@ -178,6 +180,12 @@ readOptions = do
           (Just "") -> pure Nothing
           aud' -> pure aud'
 
+    optionalListOfText :: C.Key -> C.Parser C.Config [Text]
+    optionalListOfText k =
+      C.optional k (C.list C.string) >>= \case
+        Nothing -> pure []
+        Just types -> pure types
+
     reqString :: C.Key -> C.Parser C.Config Text
     reqString k = C.required k C.string
 
@@ -273,6 +281,9 @@ readOptions = do
           |## stored proc that overrides the root "/" spec
           |## it must be inside the db-schema
           |# root-spec = "stored_proc_name"
+          |
+          |## content types to produce raw output
+          |# raw-media-types=["image/png","image/jpg"]
           |]
 
 pathParser :: Parser FilePath

src/PostgREST/Types.hs

@@ -24,7 +24,7 @@ import Protolude
 
 -- | Enumeration of currently supported response content types
 data ContentType = CTApplicationJSON | CTSingularJSON
-                 | CTTextCSV | CTTextPlain | CTTextHtml
+                 | CTTextCSV | CTTextPlain
                  | CTOpenAPI | CTOctetStream
                  | CTAny | CTOther ByteString deriving (Show, Eq)
 
@@ -37,7 +37,6 @@ toMime :: ContentType -> ByteString
 toMime CTApplicationJSON = "application/json"
 toMime CTTextCSV         = "text/csv"
 toMime CTTextPlain       = "text/plain"
-toMime CTTextHtml        = "text/html"
 toMime CTOpenAPI         = "application/openapi+json"
 toMime CTSingularJSON    = "application/vnd.pgrst.object+json"
 toMime CTOctetStream     = "application/octet-stream"
@@ -50,7 +49,6 @@ decodeContentType ct = case BS.takeWhile (/= BS.c2w ';') ct of
   "application/json"                  -> CTApplicationJSON
   "text/csv"                          -> CTTextCSV
   "text/plain"                        -> CTTextPlain
-  "text/html"                         -> CTTextHtml
   "application/openapi+json"          -> CTOpenAPI
   "application/vnd.pgrst.object+json" -> CTSingularJSON
   "application/vnd.pgrst.object"      -> CTSingularJSON
@@ -58,10 +56,6 @@ decodeContentType ct = case BS.takeWhile (/= BS.c2w ';') ct of
   "*/*"                               -> CTAny
   ct'                                 -> CTOther ct'
 
--- | ContentTypes that can get a raw/unwrapped response
-rawContentTypes :: [ContentType]
-rawContentTypes = [CTOctetStream, CTTextPlain, CTTextHtml]
-
 data PreferResolution = MergeDuplicates | IgnoreDuplicates deriving Eq
 instance Show PreferResolution where
   show MergeDuplicates  = "resolution=merge-duplicates"

test/Feature/HtmlRawOutputSpec.hs

@@ -0,0 +1,30 @@
+module Feature.HtmlRawOutputSpec where
+
+import Network.Wai (Application)
+
+import Network.HTTP.Types
+import Test.Hspec         hiding (pendingWith)
+import Test.Hspec.Wai
+import Text.Heredoc
+
+import Protolude  hiding (get)
+import SpecHelper (acceptHdrs)
+
+spec :: SpecWith Application
+spec = describe "When raw-media-types is set to \"text/html\"" $
+  it "can get raw output with Accept: text/html" $
+    request methodGet "/rpc/welcome.html" (acceptHdrs "text/html") ""
+      `shouldRespondWith`
+      [str|
+          |<html>
+          |  <head>
+          |    <title>PostgREST</title>
+          |  </head>
+          |  <body>
+          |    <h1>Welcome to PostgREST</h1>
+          |  </body>
+          |</html>
+          |]
+      { matchStatus = 200
+      , matchHeaders = ["Content-Type" <:> "text/html; charset=utf-8"]
+      }

test/Feature/RawOutputTypesSpec.hs

@@ -0,0 +1,33 @@
+module Feature.RawOutputTypesSpec where
+
+import Network.Wai (Application)
+
+import Network.HTTP.Types
+import Test.Hspec
+import Test.Hspec.Wai
+import Test.Hspec.Wai.JSON
+
+import Protolude
+import SpecHelper (acceptHdrs)
+
+spec :: SpecWith Application
+spec = describe "When raw-media-types config variable is missing or left empty" $ do
+  let firefoxAcceptHdrs = acceptHdrs "text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8"
+      chromeAcceptHdrs = acceptHdrs "text/html,application/xhtml+xml,application/xml;q=0.9,image/webp,image/apng,*/*;q=0.8,application/signed-exchange;v=b3"
+  it "responds json to a GET request with Firefox Accept headers" $
+    request methodGet "/items?id=eq.1" firefoxAcceptHdrs ""
+      `shouldRespondWith` [json| [{"id":1}] |]
+        { matchHeaders= ["Content-Type" <:> "application/json; charset=utf-8"] }
+  it "responds json to a GET request with Chrome Accept headers" $
+    request methodGet "/items?id=eq.1" chromeAcceptHdrs ""
+      `shouldRespondWith` [json| [{"id":1}] |]
+        { matchHeaders= ["Content-Type" <:> "application/json; charset=utf-8"] }
+
+  it "responds json to a GET request to RPC with Firefox Accept headers" $
+    request methodGet "/rpc/get_projects_below?id=3" chromeAcceptHdrs ""
+      `shouldRespondWith` [json|[{"id":1,"name":"Windows 7","client_id":1}, {"id":2,"name":"Windows 10","client_id":1}]|]
+        { matchHeaders= ["Content-Type" <:> "application/json; charset=utf-8"] }
+  it "responds json to a GET request to RPC with Chrome Accept headers" $
+    request methodGet "/rpc/get_projects_below?id=3" chromeAcceptHdrs ""
+      `shouldRespondWith` [json|[{"id":1,"name":"Windows 7","client_id":1}, {"id":2,"name":"Windows 10","client_id":1}]|]
+        { matchHeaders= ["Content-Type" <:> "application/json; charset=utf-8"] }

test/Feature/RpcSpec.hs

@@ -464,23 +464,6 @@ spec actualPgVersion =
             , matchHeaders = ["Content-Type" <:> "application/octet-stream; charset=utf-8"]
             }
 
-        it "can get raw output with Accept: text/html" $
-          request methodGet "/rpc/welcome.html" (acceptHdrs "text/html") ""
-            `shouldRespondWith`
-            [str|
-                |<html>
-                |  <head>
-                |    <title>PostgREST</title>
-                |  </head>
-                |  <body>
-                |    <h1>Welcome to PostgREST</h1>
-                |  </body>
-                |</html>
-                |]
-            { matchStatus = 200
-            , matchHeaders = ["Content-Type" <:> "text/html; charset=utf-8"]
-            }
-
         it "can get raw output with Accept: text/plain" $
           request methodGet "/rpc/welcome" (acceptHdrs "text/plain") ""
             `shouldRespondWith` "Welcome to PostgREST"

test/Main.hs

@@ -27,6 +27,7 @@ import qualified Feature.ConcurrentSpec
 import qualified Feature.CorsSpec
 import qualified Feature.DeleteSpec
 import qualified Feature.ExtraSearchPathSpec
+import qualified Feature.HtmlRawOutputSpec
 import qualified Feature.InsertSpec
 import qualified Feature.JsonOperatorSpec
 import qualified Feature.NoJwtSpec
@@ -37,6 +38,7 @@ import qualified Feature.ProxySpec
 import qualified Feature.QueryLimitedSpec
 import qualified Feature.QuerySpec
 import qualified Feature.RangeSpec
+import qualified Feature.RawOutputTypesSpec
 import qualified Feature.RootSpec
 import qualified Feature.RpcSpec
 import qualified Feature.SingularSpec
@@ -74,6 +76,7 @@ main = do
       nonexistentSchemaApp = return $ postgrest (testNonexistentSchemaCfg testDbConn) refDbStructure pool getTime $ pure ()
       extraSearchPathApp   = return $ postgrest (testCfgExtraSearchPath testDbConn)   refDbStructure pool getTime $ pure ()
       rootSpecApp          = return $ postgrest (testCfgRootSpec testDbConn)          refDbStructure pool getTime $ pure ()
+      htmlRawOutputApp     = return $ postgrest (testCfgHtmlRawOutput testDbConn)     refDbStructure pool getTime $ pure ()
 
   let reset :: IO ()
       reset = resetDb testDbConn
@@ -86,6 +89,7 @@ main = do
 
       specs = uncurry describe <$> [
           ("Feature.AuthSpec"               , Feature.AuthSpec.spec actualPgVersion)
+        , ("Feature.RawOutputTypesSpec"     , Feature.RawOutputTypesSpec.spec)
         , ("Feature.ConcurrentSpec"         , Feature.ConcurrentSpec.spec)
         , ("Feature.CorsSpec"               , Feature.CorsSpec.spec)
         , ("Feature.DeleteSpec"             , Feature.DeleteSpec.spec)
@@ -102,6 +106,10 @@ main = do
   hspec $ do
     mapM_ (beforeAll_ reset . before withApp) specs
 
+    -- this test runs with a raw-output-media-types set to text/html
+    beforeAll_ reset . before htmlRawOutputApp $
+      describe "Feature.HtmlRawOutputSpec" Feature.HtmlRawOutputSpec.spec
+
     -- this test runs with a different server flag
     beforeAll_ reset . before ltdApp $
       describe "Feature.QueryLimitedSpec" Feature.QueryLimitedSpec.spec

test/SpecHelper.hs

@@ -81,6 +81,8 @@ _baseCfg =  -- Connection Settings
             []
             -- No root spec override
             Nothing
+            -- Raw output media types
+            []
 
 testCfg :: Text -> AppConfig
 testCfg testDbConn = _baseCfg { configDatabase = testDbConn }
@@ -131,6 +133,9 @@ testCfgExtraSearchPath testDbConn = (testCfg testDbConn) { configExtraSearchPath
 testCfgRootSpec :: Text -> AppConfig
 testCfgRootSpec testDbConn = (testCfg testDbConn) { configRootSpec = Just $ QualifiedIdentifier "test" "root"}
 
+testCfgHtmlRawOutput :: Text -> AppConfig
+testCfgHtmlRawOutput testDbConn = (testCfg testDbConn) { configRawMediaTypes = ["text/html"] }
+
 setupDb :: Text -> IO ()
 setupDb dbConn = do
   loadFixture dbConn "database"