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

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

* removed CTTextHtml from Types.hs

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 accepts action target = serves contentTypesForRequest accepts
+responseContentTypeOrError :: [ContentType] -> [ContentType] -> Action -> Target -> Either Response ContentType
+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 ++
-                             [CTOpenAPI | tpIsRootSpec target]
+      ActionInvoke _     ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]
+                             ++ 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 ct fldNames
+binaryField :: ContentType -> [ContentType]-> [FieldName] -> Either Response (Maybe FieldName)
+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"