Accept text/plain and text/html for raw output (#1330)

2019-06-21 11:51:54 -05:00
parent 40ae7ce2b1
commit ea7d747107
8 changed files with 162 additions and 103 deletions
@@ -14,17 +14,16 @@ module PostgREST.ApiRequest (
 , userApiRequest
 ) where

-import qualified Data.Aeson               as JSON
-import qualified Data.ByteString          as BS
-import qualified Data.ByteString.Internal as BS (c2w)
-import qualified Data.ByteString.Lazy     as BL
-import qualified Data.CaseInsensitive     as CI
-import qualified Data.Csv                 as CSV
-import qualified Data.HashMap.Strict      as M
-import qualified Data.List                as L
-import qualified Data.Set                 as S
-import qualified Data.Text                as T
-import qualified Data.Vector              as V
+import qualified Data.Aeson           as JSON
+import qualified Data.ByteString      as BS
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.CaseInsensitive as CI
+import qualified Data.Csv             as CSV
+import qualified Data.HashMap.Strict  as M
+import qualified Data.List            as L
+import qualified Data.Set             as S
+import qualified Data.Text            as T
+import qualified Data.Vector          as V

 import Control.Arrow             ((***))
 import Data.Aeson.Types          (emptyArray, emptyObject)
@@ -264,23 +263,6 @@ mutuallyAgreeable sProduces cAccepts =
     then listToMaybe sProduces
     else exact

-- PRIVATE ---------------------------------------------------------------
-
-{-|
-  Warning: discards MIME parameters
-}
-decodeContentType :: BS.ByteString -> ContentType
-decodeContentType ct =
-  case BS.takeWhile (/= BS.c2w ';') ct of
-    "application/json"                  -> CTApplicationJSON
-    "text/csv"                          -> CTTextCSV
-    "application/openapi+json"          -> CTOpenAPI
-    "application/vnd.pgrst.object+json" -> CTSingularJSON
-    "application/vnd.pgrst.object"      -> CTSingularJSON
-    "application/octet-stream"          -> CTOctetStream
-    "*/*"                               -> CTAny
-    ct'                                 -> CTOther ct'
-
 type CsvData = V.Vector (M.HashMap Text BL.ByteString)

 {-|
@@ -39,7 +39,7 @@ import PostgREST.DbRequestBuilder (fieldNames, mutateRequest,
                                   readRequest)
 import PostgREST.DbStructure
 import PostgREST.Error            (PgError (..), SimpleError (..),
-                                   errorResponseFor)
+                                   errorResponseFor, singularityError)
 import PostgREST.Middleware
 import PostgREST.OpenAPI
 import PostgREST.Parsers          (pRequestColumns)
@@ -275,7 +275,7 @@ app dbStructure proc cols conf apiRequest =
                callProc qi (specifiedProcArgs cols proc) returnsScalar q cq shouldCount
                         singular (iPreferSingleObjectParameter apiRequest)
                         (contentType == CTTextCSV)
-                         (contentType == CTOctetStream) bField
+                         (contentType `elem` rawContentTypes) bField
                         (pgVersion dbStructure)
              let (tableTotal, queryTotal, body, jsonHeaders) =
                    fromMaybe (Just 0, 0, "[]", "[]") row
@@ -334,11 +334,12 @@ responseContentTypeOrError :: [ContentType] -> Action -> Target -> Either Respon
 responseContentTypeOrError accepts action target = serves contentTypesForRequest accepts
  where
    contentTypesForRequest = case action of
-      ActionRead         ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV, CTOctetStream]
+      ActionRead         ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV] ++ rawContentTypes
      ActionCreate       ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]
      ActionUpdate       ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]
      ActionDelete       ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]
-      ActionInvoke _     ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV, CTOctetStream] ++ [CTOpenAPI | tpIsRootSpec target]
+      ActionInvoke _     ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV] ++ rawContentTypes ++
+                             [CTOpenAPI | tpIsRootSpec target]
      ActionInspect      ->  [CTOpenAPI, CTApplicationJSON]
      ActionInfo         ->  [CTTextCSV]
      ActionSingleUpsert ->  [CTApplicationJSON, CTSingularJSON, CTTextCSV]
@@ -347,14 +348,18 @@ responseContentTypeOrError accepts action target = serves contentTypesForRequest
        Nothing -> Left . errorResponseFor . ContentTypeError . map toMime $ cAccepts
        Just ct -> Right ct

+{-
+  | 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 CTOctetStream fldNames =
-  if length fldNames == 1 && fieldName /= Just "*"
-    then Right fieldName
-    else Left . errorResponseFor $ BinaryFieldError
-  where
-    fieldName = headMay fldNames
-binaryField _ _ = Right Nothing
+binaryField ct fldNames
+  | ct `elem` rawContentTypes =
+      let fieldName = headMay fldNames in
+      if length fldNames == 1 && fieldName /= Just "*"
+        then Right fieldName
+        else Left . errorResponseFor $ BinaryFieldError ct
+  | otherwise = Right Nothing

 splitKeyValue :: BS.ByteString -> (BS.ByteString, BS.ByteString)
 splitKeyValue kv = (k, BS.tail v)
@@ -385,6 +390,3 @@ contentRangeH lower upper total =

 extractQueryResult :: Maybe ResultsWithCount -> ResultsWithCount
 extractQueryResult = fromMaybe (Nothing, 0, [], "")
-
-singularityError :: (Integral a) => a -> SimpleError
-singularityError = SingularityError . toInteger
@@ -12,6 +12,7 @@ module PostgREST.Error (
 , SimpleError(..)
 , errorPayload
 , checkIsFatal
+, singularityError
 ) where

 import qualified Data.Aeson                as JSON
@@ -190,7 +191,7 @@ checkIsFatal _ = Nothing

 data SimpleError
  = GucHeadersError
-  | BinaryFieldError
+  | BinaryFieldError ContentType
  | ConnectionLostError
  | PutSingletonError
  | PutMatchingPkError
@@ -204,7 +205,7 @@ data SimpleError

 instance PgrstError SimpleError where
  status GucHeadersError           = HT.status500
-  status BinaryFieldError          = HT.status406
+  status (BinaryFieldError _)      = HT.status406
  status ConnectionLostError       = HT.status503
  status PutSingletonError         = HT.status400
  status PutMatchingPkError        = HT.status400
@@ -222,8 +223,8 @@ instance PgrstError SimpleError where
 instance JSON.ToJSON SimpleError where
  toJSON GucHeadersError           = JSON.object [
    "message" .= ("response.headers guc must be a JSON array composed of objects with a single key and a string value" :: Text)]
-  toJSON BinaryFieldError          = JSON.object [
-    "message" .= ((toS (toMime CTOctetStream) <> " requested but a single column was not selected") :: Text)]
+  toJSON (BinaryFieldError ct)          = JSON.object [
+    "message" .= ((toS (toMime ct) <> " requested but a single column was not selected") :: Text)]
  toJSON ConnectionLostError       = JSON.object [
    "message" .= ("Database connection lost, retrying the connection." :: Text)]

@@ -250,3 +251,6 @@ instance JSON.ToJSON SimpleError where
 invalidTokenHeader :: Text -> Header
 invalidTokenHeader m =
  ("WWW-Authenticate", "Bearer error=\"invalid_token\", " <> "error_description=" <> show m)
+
+singularityError :: (Integral a) => a -> SimpleError
+singularityError = SingularityError . toInteger
@@ -6,11 +6,13 @@ Description : PostgREST common types and functions used by the rest of the modul

 module PostgREST.Types where

-import qualified Data.Aeson           as JSON
-import qualified Data.ByteString.Lazy as BL
-import qualified Data.CaseInsensitive as CI
-import qualified Data.HashMap.Strict  as M
-import qualified Data.Set             as S
+import qualified Data.Aeson               as JSON
+import qualified Data.ByteString          as BS
+import qualified Data.ByteString.Internal as BS (c2w)
+import qualified Data.ByteString.Lazy     as BL
+import qualified Data.CaseInsensitive     as CI
+import qualified Data.HashMap.Strict      as M
+import qualified Data.Set                 as S
 import qualified GHC.Show

 import Network.HTTP.Types.Header (Header, hContentType)
@@ -21,9 +23,10 @@ import PostgREST.RangeQuery (NonnegRange)
 import Protolude

 -- | Enumeration of currently supported response content types
-data ContentType = CTApplicationJSON | CTTextCSV | CTOpenAPI
-                 | CTSingularJSON | CTOctetStream
-                 | CTAny | CTOther ByteString deriving Eq
+data ContentType = CTApplicationJSON | CTSingularJSON
+                 | CTTextCSV | CTTextPlain | CTTextHtml
+                 | CTOpenAPI | CTOctetStream
+                 | CTAny | CTOther ByteString deriving (Show, Eq)

 -- | Convert from ContentType to a full HTTP Header
 toHeader :: ContentType -> Header
@@ -33,12 +36,32 @@ toHeader ct = (hContentType, toMime ct <> "; charset=utf-8")
 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"
 toMime CTAny             = "*/*"
 toMime (CTOther ct)      = ct

+-- | Convert from ByteString to ContentType. Warning: discards MIME parameters
+decodeContentType :: BS.ByteString -> ContentType
+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
+  "application/octet-stream"          -> CTOctetStream
+  "*/*"                               -> 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"