Reduce app function (#733)

Simplify the big app function
2016-11-10 20:42:00 -08:00
parent c3822da2d2
commit 41c1cf6e01
6 changed files with 247 additions and 221 deletions
@@ -54,6 +54,7 @@ library
                     , configurator
                     , containers
                     , contravariant
+                     , either
                     , hasql
                     , hasql-pool == 0.4.1
                     , hasql-transaction == 0.4.5.1
@@ -1,4 +1,17 @@
-module PostgREST.ApiRequest where
+{-|
+Module      : PostgREST.ApiRequest
+Description : PostgREST functions to translate HTTP request to a domain type called ApiRequest.
+-}
+module PostgREST.ApiRequest ( ApiRequest(..)
+                            , ContentType(..)
+                            , Action(..)
+                            , Target(..)
+                            , PreferRepresentation (..)
+                            , mutuallyAgreeable
+                            , toHeader
+                            , userApiRequest
+                            , toMime
+                            ) where

 import           Protolude

@@ -33,6 +46,7 @@ type RequestBody = BL.ByteString
 data Action = ActionCreate | ActionRead
            | ActionUpdate | ActionDelete
            | ActionInfo   | ActionInvoke
+            | ActionInspect
            | ActionInappropriate
            deriving Eq
 -- | The target db object of a user action
@@ -40,6 +54,7 @@ data Target = TargetIdent QualifiedIdentifier
            | TargetProc  QualifiedIdentifier
            | TargetRoot
            | TargetUnknown [Text]
+            deriving Eq
 -- | How to return the inserted data
 data PreferRepresentation = Full | HeadersOnly | None deriving Eq
                          --
@@ -47,15 +62,17 @@ data PreferRepresentation = Full | HeadersOnly | None deriving Eq
 data ContentType = CTApplicationJSON | CTTextCSV | CTOpenAPI
                 | CTAny | CTOther BS.ByteString deriving Eq

-ctToHeader :: ContentType -> Header
-ctToHeader ct = (hContentType, toHeader ct <> "; charset=utf-8")
+-- | Convert from ContentType to a full HTTP Header
+toHeader :: ContentType -> Header
+toHeader ct = (hContentType, toMime ct <> "; charset=utf-8")

-toHeader :: ContentType -> ByteString
-toHeader CTApplicationJSON = "application/json"
-toHeader CTTextCSV         = "text/csv"
-toHeader CTOpenAPI         = "application/openapi+json"
-toHeader CTAny             = "*/*"
-toHeader (CTOther ct)      = ct
+-- | Convert from ContentType to a ByteString representing the mime type
+toMime :: ContentType -> ByteString
+toMime CTApplicationJSON = "application/json"
+toMime CTTextCSV         = "text/csv"
+toMime CTOpenAPI         = "application/openapi+json"
+toMime CTAny             = "*/*"
+toMime (CTOther ct)      = ct

 {-|
  Describes what the user wants to do. This data type is a
@@ -104,7 +121,9 @@ userApiRequest schema req reqBody =
               else ActionInappropriate
          else
            case method of
-               "GET"     -> ActionRead
+               "GET"     -> if target == TargetRoot
+                              then ActionInspect
+                              else ActionRead
               "POST"    -> ActionCreate
               "PATCH"   -> ActionUpdate
               "DELETE"  -> ActionDelete
@@ -137,7 +156,7 @@ userApiRequest schema req reqBody =
                      . map (toS *** JSON.String . toS) . parseSimpleQuery
                      $ toS reqBody
        ct ->
-          PayloadParseError $ "Content-Type not acceptable: " <> toHeader ct
+          PayloadParseError $ "Content-Type not acceptable: " <> toMime ct
      relevantPayload = case action of
        ActionCreate -> Just payload
        ActionUpdate -> Just payload
@@ -281,6 +300,3 @@ ensureUniform arr =
  if (V.length objs == V.length arr) && areKeysUniform
    then Just (UniformObjects objs)
    else Nothing
-
-readBSMaybe :: Read a => ByteString -> Maybe a
-readBSMaybe = readMaybe . toS
@@ -15,6 +15,7 @@ import           Data.Ranged.Ranges        (emptyRange)
 import           Data.Text                 (replace, strip, isInfixOf, dropWhile, drop, intercalate)
 import           Data.Time.Clock.POSIX     (POSIXTime)
 import           Data.Tree
+import           Data.Either.Combinators   (mapLeft)

 import qualified Hasql.Pool                as P
 import qualified Hasql.Transaction         as HT
@@ -38,13 +39,14 @@ import qualified Hasql.Transaction         as H

 import qualified Data.HashMap.Strict       as M

-import           PostgREST.ApiRequest   (ApiRequest(..), ContentType(..)
-                                            , Action(..), Target(..)
-                                            , PreferRepresentation (..)
-                                            , userApiRequest, mutuallyAgreeable
-                                            , ctToHeader
-                                            , userApiRequest
-                                            , toHeader)
+import           PostgREST.ApiRequest   ( ApiRequest(..), ContentType(..)
+                                        , Action(..), Target(..)
+                                        , PreferRepresentation (..)
+                                        , mutuallyAgreeable
+                                        , toHeader
+                                        , userApiRequest
+                                        , toMime
+                                        )
 import           PostgREST.Auth            (jwtClaims, containsRole)
 import           PostgREST.Config          (AppConfig (..))
 import           PostgREST.DbStructure
@@ -98,201 +100,206 @@ transactionMode _ = HT.Write

 app :: DbStructure -> AppConfig -> ApiRequest -> H.Transaction Response
 app dbStructure conf apiRequest =
-  case (iAction apiRequest, iTarget apiRequest, iPayload apiRequest) of
+  case responseContentTypeOrError (iAccepts apiRequest) (iAction apiRequest) of
+    Left errorResponse -> return errorResponse
+    Right contentType ->
+      case (iAction apiRequest, iTarget apiRequest, iPayload apiRequest) of

-    (ActionRead, TargetIdent qi, Nothing) ->
-      serves [CTApplicationJSON, CTTextCSV] (iAccepts apiRequest) $ \contentType ->
-      case readSqlParts of
-        Left e -> return $ responseLBS status400 [jsonH] $ toS e
-        Right (q, cq) -> do
-          let singular = iPreferSingular apiRequest
-              stm = createReadStatement q cq singular
-                    shouldCount (contentType == CTTextCSV)
-          respondToRange $ do
-            row <- H.query () stm
-            let (tableTotal, queryTotal, _ , body) = row
-            if singular
-            then return $ if queryTotal <= 0
-              then responseLBS status404 [] ""
-              else responseLBS status200 [ctToHeader contentType] (toS body)
-            else do
-              let (status, contentRange) = rangeHeader queryTotal tableTotal
-                  canonical = iCanonicalQS apiRequest
-              return $ responseLBS status
-                [ctToHeader contentType, contentRange,
-                  ("Content-Location",
-                    "/" <> toS (qiName qi) <>
-                      if BS.null canonical then "" else "?" <> toS canonical
-                  )
-                ] (toS body)
+        (ActionRead, TargetIdent qi, Nothing) ->
+          case readSqlParts of
+            Left errorResponse -> return errorResponse
+            Right (q, cq) -> respondToRange $ do
+              let singular = iPreferSingular apiRequest
+                  stm = createReadStatement q cq singular shouldCount (contentType == CTTextCSV)
+              row <- H.query () stm
+              let (tableTotal, queryTotal, _ , body) = row
+              if singular
+              then return $ if queryTotal <= 0
+                then notFound
+                else responseLBS status200 [toHeader contentType] (toS body)
+              else do
+                let (status, contentRange) = rangeHeader queryTotal tableTotal
+                    canonical = iCanonicalQS apiRequest
+                    --TargetIdent qi = iTarget apiRequest
+                return $ responseLBS status
+                  [toHeader contentType, contentRange,
+                    ("Content-Location",
+                      "/" <> toS (qiName qi) <>
+                        if BS.null canonical then "" else "?" <> toS canonical
+                    )
+                  ] (toS body)

-    (ActionCreate, TargetIdent qi@(QualifiedIdentifier _ table),
-     Just payload@(PayloadJSON uniform@(UniformObjects rows))) ->
-      serves [CTApplicationJSON, CTTextCSV] (iAccepts apiRequest) $ \contentType ->
-      case mutateSqlParts of
-        Left e -> return $ responseLBS status400 [jsonH] $ toS e
-        Right (sq,mq) -> do
-          let isSingle = (==1) $ V.length rows
-          when (not isSingle && iPreferSingular apiRequest) $
-            HT.sql [P6.q| DO $$
-                       BEGIN RAISE EXCEPTION cardinality_violation
-                       USING MESSAGE =
-                         'plurality=singular specified, but more than one object would be inserted';
-                       END $$;
-                     |]
-          let pKeys = map pkName $ filter (filterPk schema table) allPrKeys -- would it be ok to move primary key detection in the query itself?
-          let stm = createWriteStatement qi sq mq isSingle (iPreferRepresentation apiRequest) pKeys (contentType == CTTextCSV) payload
-          row <- H.query uniform stm
-          let (_, _, fs, body) = extractQueryResult row
-              headers = catMaybes [
-                  if null fs
-                    then Nothing
-                    else Just (hLocation, "/" <> toS table <> renderLocationFields fs)
-                , if iPreferRepresentation apiRequest == Full
-                    then Just $ ctToHeader contentType
-                    else Nothing
-                , Just . contentRangeH 1 0 $
-                    toInteger <$> if shouldCount then Just (V.length rows) else Nothing
-                ]
+        (ActionCreate, TargetIdent qi@(QualifiedIdentifier _ table), Just payload@(PayloadJSON uniform@(UniformObjects rows))) ->
+          case mutateSqlParts of
+            Left errorResponse -> return errorResponse
+            Right (sq, mq) -> do
+              let isSingle = (==1) $ V.length rows
+              when (not isSingle && iPreferSingular apiRequest) $
+                HT.sql [P6.q| DO $$
+                          BEGIN RAISE EXCEPTION cardinality_violation
+                          USING MESSAGE =
+                            'plurality=singular specified, but more than one object would be inserted';
+                          END $$;
+                        |]
+              let pKeys = map pkName $ filter (filterPk schema table) allPrKeys -- would it be ok to move primary key detection in the query itself?
+              let stm = createWriteStatement qi sq mq isSingle (iPreferRepresentation apiRequest) pKeys (contentType == CTTextCSV) payload
+              row <- H.query uniform stm
+              let (_, _, fs, body) = extractQueryResult row
+                  headers = catMaybes [
+                      if null fs
+                        then Nothing
+                        else Just (hLocation, "/" <> toS table <> renderLocationFields fs)
+                    , if iPreferRepresentation apiRequest == Full
+                        then Just $ toHeader contentType
+                        else Nothing
+                    , Just . contentRangeH 1 0 $
+                        toInteger <$> if shouldCount then Just (V.length rows) else Nothing
+                    ]

-          return . responseLBS status201 headers $
-            if iPreferRepresentation apiRequest == Full
-               then toS body else ""
+              return . responseLBS status201 headers $
+                if iPreferRepresentation apiRequest == Full
+                  then toS body else ""

-    (ActionUpdate, TargetIdent qi, Just payload@(PayloadJSON uniform)) ->
-      serves [CTApplicationJSON, CTTextCSV] (iAccepts apiRequest) $ \contentType ->
-      case mutateSqlParts of
-        Left e -> return $ responseLBS status400 [jsonH] $ toS e
-        Right (sq,mq) -> do
-          let singular = iPreferSingular apiRequest
-              stm = createWriteStatement qi sq mq singular (iPreferRepresentation apiRequest) [] (contentType == CTTextCSV) payload
-          row <- H.query uniform stm
-          let (_, queryTotal, _, body) = extractQueryResult row
-          when (singular && queryTotal > 1) $
-            HT.sql [P6.q| DO $$
-                       BEGIN RAISE EXCEPTION cardinality_violation
-                       USING MESSAGE =
-                         'plurality=singular specified, but more than one object would be updated';
-                       END $$;
-                     |]
-          let r = contentRangeH 0 (toInteger $ queryTotal-1)
-                    (toInteger <$> if shouldCount then Just queryTotal else Nothing)
-              s = case () of _ | queryTotal == 0 -> status404
-                               | iPreferRepresentation apiRequest == Full -> status200
-                               | otherwise -> status204
-          return $ if iPreferRepresentation apiRequest == Full
-            then responseLBS s [ctToHeader contentType, r] (toS body)
-            else responseLBS s [r] ""
+        (ActionUpdate, TargetIdent qi, Just payload@(PayloadJSON uniform)) ->
+          case mutateSqlParts of
+            Left errorResponse -> return errorResponse
+            Right (sq, mq) -> do
+              let singular = iPreferSingular apiRequest
+                  stm = createWriteStatement qi sq mq singular (iPreferRepresentation apiRequest) [] (contentType == CTTextCSV) payload
+              row <- H.query uniform stm
+              let (_, queryTotal, _, body) = extractQueryResult row
+              when (singular && queryTotal > 1) $
+                HT.sql [P6.q| DO $$
+                          BEGIN RAISE EXCEPTION cardinality_violation
+                          USING MESSAGE =
+                            'plurality=singular specified, but more than one object would be updated';
+                          END $$;
+                        |]
+              let r = contentRangeH 0 (toInteger $ queryTotal-1)
+                        (toInteger <$> if shouldCount then Just queryTotal else Nothing)
+                  s = case () of _ | queryTotal == 0 -> status404
+                                  | iPreferRepresentation apiRequest == Full -> status200
+                                  | otherwise -> status204
+              return $ if iPreferRepresentation apiRequest == Full
+                then responseLBS s [toHeader contentType, r] (toS body)
+                else responseLBS s [r] ""

-    (ActionDelete, TargetIdent qi, Nothing) ->
-      serves [CTApplicationJSON, CTTextCSV] (iAccepts apiRequest) $ \contentType ->
-      case mutateSqlParts of
-        Left e -> return $ responseLBS status400 [jsonH] $ toS e
-        Right (sq,mq) -> do
-          let emptyUniform = UniformObjects V.empty
-              fakeload = PayloadJSON emptyUniform
-              stm = createWriteStatement qi sq mq False (iPreferRepresentation apiRequest) [] (contentType == CTTextCSV) fakeload
-          row <- H.query emptyUniform stm
-          let (_, queryTotal, _, body) = extractQueryResult row
-              r = contentRangeH 1 0 $
-                    toInteger <$> if shouldCount then Just queryTotal else Nothing
-          return $ if queryTotal == 0
-            then notFound
-            else if iPreferRepresentation apiRequest == Full
-              then responseLBS status200 [ctToHeader contentType, r] (toS body)
-              else responseLBS status204 [r] ""
+        (ActionDelete, TargetIdent qi, Nothing) ->
+          case mutateSqlParts of
+            Left errorResponse -> return errorResponse
+            Right (sq, mq) -> do
+              let emptyUniform = UniformObjects V.empty
+                  fakeload = PayloadJSON emptyUniform
+                  stm = createWriteStatement qi sq mq False (iPreferRepresentation apiRequest) [] (contentType == CTTextCSV) fakeload
+              row <- H.query emptyUniform stm
+              let (_, queryTotal, _, body) = extractQueryResult row
+                  r = contentRangeH 1 0 $
+                        toInteger <$> if shouldCount then Just queryTotal else Nothing
+              return $ if queryTotal == 0
+                then notFound
+                else if iPreferRepresentation apiRequest == Full
+                  then responseLBS status200 [toHeader contentType, r] (toS body)
+                  else responseLBS status204 [r] ""

-    (ActionInfo, TargetIdent (QualifiedIdentifier tSchema tTable), Nothing) ->
-      let mTable = find (\t -> tableName t == tTable && tableSchema t == tSchema) (dbTables dbStructure) in
-      case mTable of
-        Nothing -> return notFound
-        Just table ->
-          let acceptH = (hAllow, if tableInsertable table then "GET,POST,PATCH,DELETE" else "GET") in
-          return $ responseLBS status200 [allOrigins, acceptH] ""
+        (ActionInfo, TargetIdent (QualifiedIdentifier tSchema tTable), Nothing) ->
+          let mTable = find (\t -> tableName t == tTable && tableSchema t == tSchema) (dbTables dbStructure) in
+          case mTable of
+            Nothing -> return notFound
+            Just table ->
+              let acceptH = (hAllow, if tableInsertable table then "GET,POST,PATCH,DELETE" else "GET") in
+              return $ responseLBS status200 [allOrigins, acceptH] ""

-    (ActionInvoke, TargetProc qi,
-     Just (PayloadJSON (UniformObjects payload))) -> do
-        let p = V.head payload
-            singular = iPreferSingular apiRequest
-        serves [CTApplicationJSON] (iAccepts apiRequest) $ \_ -> case readSqlParts of
-          Left e -> return $ responseLBS status400 [jsonH] $ toS e
-          Right (q,cq) -> respondToRange $ do
-            row <- H.query () (callProc qi p q cq topLevelRange shouldCount singular)
-            let (tableTotal, queryTotal, body) =
-                  fromMaybe (Just 0, 0, emptyArray) row
-                (status, contentRange) = rangeHeader queryTotal tableTotal
-            return $ responseLBS status [jsonH, contentRange] (toS . encode $ body)
+        (ActionInvoke, TargetProc qi, Just (PayloadJSON (UniformObjects payload))) ->
+          case readSqlParts of
+            Left errorResponse -> return errorResponse
+            Right (q, cq) -> respondToRange $ do
+              let p = V.head payload
+                  singular = iPreferSingular apiRequest
+              row <- H.query () (callProc qi p q cq topLevelRange shouldCount singular)
+              let (tableTotal, queryTotal, body) =
+                    fromMaybe (Just 0, 0, emptyArray) row
+                  (status, contentRange) = rangeHeader queryTotal tableTotal
+              return $ responseLBS status [jsonH, contentRange] (toS . encode $ body)

-    (ActionRead, TargetRoot, Nothing) -> do
-      let host = configHost conf
-          port = toInteger $ configPort conf
-          proxy = pickProxy $ toS <$> configProxyUri conf
-          uri Nothing = ("http", host, port, "/")
-          uri (Just Proxy { proxyScheme = s, proxyHost = h, proxyPort = p, proxyPath = b }) = (s, h, p, b)
-          uri' = uri proxy
-          encodeApi ti = encodeOpenAPI (map snd $ dbProcs dbStructure) ti uri'
-      serves [CTOpenAPI] (iAccepts apiRequest) $ \_ -> do
-        body <- encodeApi . toTableInfo <$> H.query schema accessibleTables
-        return $ responseLBS status200 [openapiH] $ toS body
+        (ActionInspect, TargetRoot, Nothing) -> do
+          let host = configHost conf
+              port = toInteger $ configPort conf
+              proxy = pickProxy $ toS <$> configProxyUri conf
+              uri Nothing = ("http", host, port, "/")
+              uri (Just Proxy { proxyScheme = s, proxyHost = h, proxyPort = p, proxyPath = b }) = (s, h, p, b)
+              uri' = uri proxy
+              encodeApi ti = encodeOpenAPI (map snd $ dbProcs dbStructure) ti uri'
+          body <- encodeApi . toTableInfo <$> H.query schema accessibleTables
+          return $ responseLBS status200 [toHeader CTOpenAPI] $ toS body

-    (ActionInappropriate, _, _) -> return $ responseLBS status405 [] ""
+        (_, _, Just (PayloadParseError e)) ->
+          return $ errResponse status400 $
+            toS (formatGeneralError "Cannot parse request payload" (toS e))

-    (_, _, Just (PayloadParseError e)) ->
-      return $ responseLBS status400 [jsonH] $
-        toS (formatGeneralError "Cannot parse request payload" (toS e))
+        _ -> return notFound

-    (_, TargetUnknown _, _) -> return notFound
+    where
+      toTableInfo :: [Table] -> [(Table, [Column], [Text])]
+      toTableInfo = map (\t ->
+        let tSchema = tableSchema t
+            tTable = tableName t
+            cols = filter (filterCol tSchema tTable) $ dbColumns dbStructure
+            pkeys = map pkName $ filter (filterPk tSchema tTable) allPrKeys
+        in (t, cols, pkeys))
+      notFound = responseLBS status404 [] ""
+      filterPk sc table pk = sc == (tableSchema . pkTable) pk && table == (tableName . pkTable) pk
+      filterCol :: Schema -> TableName -> Column -> Bool
+      filterCol sc tb Column{colTable=Table{tableSchema=s, tableName=t}} = s==sc && t==tb
+      filterCol _ _ _ =  False
+      allPrKeys = dbPrimaryKeys dbStructure
+      allOrigins = ("Access-Control-Allow-Origin", "*") :: Header
+      jsonH = toHeader CTApplicationJSON
+      shouldCount = iPreferCount apiRequest
+      schema = toS $ configSchema conf
+      topLevelRange = fromMaybe allRange $ M.lookup "limit" $ iRange apiRequest
+      rangeHeader queryTotal tableTotal =
+        let lower = rangeOffset topLevelRange
+            upper = lower + toInteger queryTotal - 1
+            contentRange = contentRangeH lower upper (toInteger <$> tableTotal)
+            status = rangeStatus lower upper (toInteger <$> tableTotal)
+        in (status, contentRange)

-    (_, _, _) -> return notFound
+      mapSnd f (a, b) = (a, f b)
+      readDbRequest = DbRead <$> readRequest (configMaxRows conf) (dbRelations dbStructure) (map (mapSnd pdReturnType) $ dbProcs dbStructure) apiRequest
+      mutateDbRequest = DbMutate <$> mutateRequest apiRequest
+      selectQuery = requestToQuery schema False <$> readDbRequest
+      mutateQuery = requestToQuery schema False <$> mutateDbRequest
+      countQuery = requestToCountQuery schema <$> readDbRequest
+      readSqlParts = (,) <$> selectQuery <*> countQuery
+      mutateSqlParts = (,) <$> selectQuery <*> mutateQuery
+      respondToRange response =
+        if topLevelRange == emptyRange
+          then return $ errResponse status416 "HTTP Range error"
+          else response

- where
-  toTableInfo :: [Table] -> [(Table, [Column], [Text])]
-  toTableInfo = map (\t ->
-    let tSchema = tableSchema t
-        tTable = tableName t
-        cols = filter (filterCol tSchema tTable) $ dbColumns dbStructure
-        pkeys = map pkName $ filter (filterPk tSchema tTable) allPrKeys
-     in
-        (t, cols, pkeys))
-  notFound = responseLBS status404 [] ""
-  filterPk sc table pk = sc == (tableSchema . pkTable) pk && table == (tableName . pkTable) pk
-  filterCol :: Schema -> TableName -> Column -> Bool
-  filterCol sc tb Column{colTable=Table{tableSchema=s, tableName=t}} = s==sc && t==tb
-  filterCol _ _ _ =  False
-  allPrKeys = dbPrimaryKeys dbStructure
-  allOrigins = ("Access-Control-Allow-Origin", "*") :: Header
-  jsonH = ctToHeader CTApplicationJSON
-  openapiH = ctToHeader CTOpenAPI
-  schema = toS $ configSchema conf
-  shouldCount = iPreferCount apiRequest
-  topLevelRange = fromMaybe allRange $ M.lookup "limit" $ iRange apiRequest
-  mapSnd f (a, b) = (a, f b)
-  readDbRequest = DbRead <$> buildReadRequest (configMaxRows conf) (dbRelations dbStructure) (map (mapSnd pdReturnType) $ dbProcs dbStructure) apiRequest
-  mutateDbRequest = DbMutate <$> buildMutateRequest apiRequest
-  selectQuery = requestToQuery schema False <$> readDbRequest
-  countQuery = requestToCountQuery schema <$> readDbRequest
-  mutateQuery = requestToQuery schema False <$> mutateDbRequest
-  readSqlParts = (,) <$> selectQuery <*> countQuery
-  mutateSqlParts = (,) <$> selectQuery <*> mutateQuery
-  respondToRange response = if topLevelRange == emptyRange
-                            then return $ errResponse status416 "HTTP Range error"
-                            else response
-  rangeHeader queryTotal tableTotal = let lower = rangeOffset topLevelRange
-                                          upper = lower + toInteger queryTotal - 1
-                                          contentRange = contentRangeH lower upper (toInteger <$> tableTotal)
-                                          status = rangeStatus lower upper (toInteger <$> tableTotal)
-                                      in (status, contentRange)
-
-
-serves :: Monad m => [ContentType] -> [ContentType] ->
-  (ContentType -> m Response) -> m Response
-serves sProduces cAccepts resp =
-  case mutuallyAgreeable sProduces cAccepts of
-    Nothing -> do
-      let failed = intercalate ", " $ map (toS . toHeader) cAccepts
-      return $ errResponse status415 $
-        "None of these Content-Types are available: " <> failed
-    Just ct -> resp ct
+responseContentTypeOrError :: [ContentType] -> Action -> Either Response ContentType
+responseContentTypeOrError accepts action =
+  case action of
+    ActionInappropriate -> Left $ errResponse status405 "Unsupported HTTP verb"
+    _ -> serves contentTypesForRequest accepts
+  where
+    contentTypesForRequest =
+      case action of
+        ActionRead -> [CTApplicationJSON, CTTextCSV]
+        ActionCreate -> [CTApplicationJSON, CTTextCSV]
+        ActionUpdate -> [CTApplicationJSON, CTTextCSV]
+        ActionDelete -> [CTApplicationJSON, CTTextCSV]
+        ActionInvoke -> [CTApplicationJSON]
+        ActionInspect -> [CTOpenAPI]
+        ActionInfo -> [CTTextCSV]
+        ActionInappropriate -> []
+    serves sProduces cAccepts =
+      case mutuallyAgreeable sProduces cAccepts of
+        Nothing -> do
+          let failed = intercalate ", " $ map (toS . toMime) cAccepts
+          Left $ errResponse status415 $
+            "None of these Content-Types are available: " <> failed
+        Just ct -> Right ct

 splitKeyValue :: BS.ByteString -> (BS.ByteString, BS.ByteString)
 splitKeyValue kv = (k, BS.tail v)
@@ -372,11 +379,12 @@ treeRestrictRange maxRows_ request = pure $ nodeRestrictRange maxRows_ `fmap` re
    nodeRestrictRange :: Maybe Integer -> ReadNode -> ReadNode
    nodeRestrictRange m (q@Select {range_=r}, i) = (q{range_=restrictRange m r }, i)

-buildReadRequest :: Maybe Integer -> [Relation] -> [(Text, Text)] -> ApiRequest -> Either Text ReadRequest
-buildReadRequest maxRows allRels allProcs apiRequest  =
+readRequest :: Maybe Integer -> [Relation] -> [(Text, Text)] -> ApiRequest -> Either Response ReadRequest
+readRequest maxRows allRels allProcs apiRequest  =
+  mapLeft (errResponse status400) $
  treeRestrictRange maxRows =<<
  augumentRequestWithJoin schema relations =<<
-  first formatParserError readRequest
+  first formatParserError parseReadRequest
  where
    (schema, rootTableName) = fromJust $ -- Make it safe
      let target = iTarget apiRequest in
@@ -395,8 +403,8 @@ buildReadRequest maxRows allRels allProcs apiRequest  =
    action :: Action
    action = iAction apiRequest

-    readRequest :: Either ParseError ReadRequest
-    readRequest = addFiltersOrdersRanges apiRequest <*>
+    parseReadRequest :: Either ParseError ReadRequest
+    parseReadRequest = addFiltersOrdersRanges apiRequest <*>
      parse (pRequestSelect rootName) ("failed to parse select parameter <<" <> toS selStr <> ">>") (toS selStr)
      where
        selStr = iSelect apiRequest
@@ -413,12 +421,13 @@ buildReadRequest maxRows allRels allProcs apiRequest  =
      _       -> allRels
      where fakeSourceRelations = mapMaybe (toSourceRelation rootTableName) allRels -- see comment in toSourceRelation

-buildMutateRequest :: ApiRequest -> Either Text MutateRequest
-buildMutateRequest apiRequest = case action of
-  ActionCreate -> Insert rootTableName <$> pure payload
-  ActionUpdate -> Update rootTableName <$> pure payload <*> filters
-  ActionDelete -> Delete rootTableName <$> filters
-  _        -> Left "Unsupported HTTP verb"
+mutateRequest :: ApiRequest -> Either Response MutateRequest
+mutateRequest apiRequest = mapLeft (errResponse status400) $
+  case action of
+    ActionCreate -> Insert rootTableName <$> pure payload
+    ActionUpdate -> Update rootTableName <$> pure payload <*> filters
+    ActionDelete -> Delete rootTableName <$> filters
+    _        -> Left "Unsupported HTTP verb"
  where
    action = iAction apiRequest
    payload = fromJust $ iPayload apiRequest
@@ -12,17 +12,17 @@ import qualified Hasql.Pool                as P
 import qualified Hasql.Session             as H
 import qualified Network.HTTP.Types.Status as HT
 import           Network.Wai               (Response, responseLBS)
-import           PostgREST.ApiRequest      (ctToHeader, ContentType(..))
+import           PostgREST.ApiRequest      (toHeader, ContentType(..))

 errResponse :: HT.Status -> Text -> Response
 errResponse status message = responseLBS status
-  [ctToHeader CTApplicationJSON]
+  [toHeader CTApplicationJSON]
  (toS $ T.concat ["{\"message\":\"",message,"\"}"])

 pgErrResponse :: Bool -> P.UsageError -> Response
 pgErrResponse authed e =
  let status = httpStatus authed e
-      jsonType = ctToHeader CTApplicationJSON
+      jsonType = toHeader CTApplicationJSON
      wwwAuth = ("WWW-Authenticate", "Bearer")
      hdrs = if status == HT.status401
                then [jsonType, wwwAuth]
@@ -15,7 +15,7 @@ import           Network.Wai.Middleware.Gzip   (def, gzip)
 import           Network.Wai.Middleware.Static (only, staticPolicy)

 import           PostgREST.ApiRequest          (ApiRequest(..), ContentType(..),
-                                                ctToHeader)
+                                                toHeader)
 import           PostgREST.Auth                (claimsToSQL, JWTAttempt(..))
 import           PostgREST.Config              (AppConfig (..), corsPolicy)
 import           PostgREST.Error               (errResponse)
@@ -40,7 +40,7 @@ runWithClaims conf eClaims app req =
    anon = String . toS $ configAnonRole conf
    customReqCheck = (\f -> "select " <> toS f <> "();") <$> configReqCheck conf
    unauthed message = responseLBS unauthorized401
-      [ ctToHeader CTApplicationJSON
+      [ toHeader CTApplicationJSON
      , ( "WWW-Authenticate"
        , "Bearer error=\"invalid_token\", " <>
          "error_description=\"" <> message <> "\""
@@ -20,14 +20,14 @@ import           Protolude hiding              (concat, (&), Proxy, get, interca

 import           Data.Swagger

-import           PostgREST.ApiRequest        (ContentType(..), toHeader)
+import           PostgREST.ApiRequest        (ContentType(..), toMime)
 import           PostgREST.Config            (prettyVersion)
 import           PostgREST.QueryBuilder      (operators)
 import           PostgREST.Types             (Table(..), Column(..), PgArg(..),
                                              Proxy(..), ProcDescription(..))

 makeMimeList :: [ContentType] -> MimeList
-makeMimeList cs = MimeList $ map (fromString . toS . toHeader) cs
+makeMimeList cs = MimeList $ map (fromString . toS . toMime) cs

 toSwaggerType :: Text -> SwaggerType t
 toSwaggerType "text"      = SwaggerString