Introduce the type ApiRequestError and make userApiRequest return an Either ApiRequestError ApiRequest

src/PostgREST/ApiRequest.hs

@@ -3,6 +3,7 @@ Module      : PostgREST.ApiRequest
 Description : PostgREST functions to translate HTTP request to a domain type called ApiRequest.
 -}
 module PostgREST.ApiRequest ( ApiRequest(..)
+                            , ApiRequestError(..)
                             , ContentType(..)
                             , Action(..)
                             , Target(..)
@@ -62,6 +63,8 @@ data PreferRepresentation = Full | HeadersOnly | None deriving Eq
 data ContentType = CTApplicationJSON | CTTextCSV | CTOpenAPI
                  | CTAny | CTOther BS.ByteString deriving Eq
 
+data ApiRequestError = ErrorActionInappropriate | ErrorInvalidBody ByteString deriving (Show, Eq)
+
 -- | Convert from ContentType to a full HTTP Header
 toHeader :: ContentType -> Header
 toHeader ct = (hContentType, toMime ct <> "; charset=utf-8")
@@ -113,84 +116,86 @@ data ApiRequest = ApiRequest {
   }
 
 -- | Examines HTTP request and translates it into user intent.
-userApiRequest :: Schema -> Request -> RequestBody -> ApiRequest
+userApiRequest :: Schema -> Request -> RequestBody -> Either ApiRequestError ApiRequest
-userApiRequest schema req reqBody =
+userApiRequest schema req reqBody
-  let action =
+  | isTargetingProc && method /= "POST" = Left ErrorActionInappropriate
-        if isTargetingProc
+  | isError = Left $ ErrorInvalidBody payloadError
-          then
+  | otherwise = Right ApiRequest {
-            if method == "POST"
+      iAction = action
-               then ActionInvoke
+      , iTarget = target
-               else ActionInappropriate
+      , iRange = ranges
-          else
+      , iAccepts = fromMaybe [CTAny] $
-            case method of
+        map decodeContentType . parseHttpAccept <$> lookupHeader "accept"
-               "GET"     -> if target == TargetRoot
+      , iPayload = relevantPayload
-                              then ActionInspect
+      , iPreferRepresentation = representation
-                              else ActionRead
+      , iPreferSingular = singular
-               "POST"    -> ActionCreate
+      , iPreferSingleObjectParameter = singleObject
-               "PATCH"   -> ActionUpdate
+      , iPreferCount = not singular && hasPrefer "count=exact"
-               "DELETE"  -> ActionDelete
+      , iFilters = [ (toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, k /= "select", not (endingIn ["order", "limit", "offset"] k) ]
-               "OPTIONS" -> ActionInfo
+      , iSelect = toS $ fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qParams
-               _         -> ActionInappropriate
+      , iOrder = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["order"] k ]
-      target = case path of
+      , iCanonicalQS = toS $ urlEncodeVars
-                 []            -> TargetRoot
+        . L.sortBy (comparing fst)
-                 [table]       -> TargetIdent
+        . map (join (***) toS)
-                                  $ QualifiedIdentifier schema table
+        . parseSimpleQuery
-                 ["rpc", proc] -> TargetProc
+        $ rawQueryString req
-                                  $ QualifiedIdentifier schema proc
+      , iJWT = tokenStr
-                 other         -> TargetUnknown other
+      }
-      payload = case decodeContentType
-                     . fromMaybe "application/json"
-                     $ lookupHeader "content-type" of
-        CTApplicationJSON ->
-          either (PayloadParseError . toS)
-            (\val -> case ensureUniform (pluralize val) of
-              Nothing -> PayloadParseError "All object keys must match"
-              Just json -> PayloadJSON json)
-            (JSON.eitherDecode reqBody)
-        CTTextCSV ->
-          either (PayloadParseError . toS)
-            (\val -> case ensureUniform (csvToJson val) of
-              Nothing -> PayloadParseError "All lines must have same number of fields"
-              Just json -> PayloadJSON json)
-            (CSV.decodeByName reqBody)
-        CTOther "application/x-www-form-urlencoded" ->
-          PayloadJSON . UniformObjects . V.singleton . M.fromList
-                      . map (toS *** JSON.String . toS) . parseSimpleQuery
-                      $ toS reqBody
-        ct ->
-          PayloadParseError $ "Content-Type not acceptable: " <> toMime ct
-      relevantPayload = case action of
-        ActionCreate -> Just payload
-        ActionUpdate -> Just payload
-        ActionInvoke -> Just payload
-        _            -> Nothing in
-
-  ApiRequest {
-    iAction = action
-  , iTarget = target
-  , iRange = ranges
-  , iAccepts = fromMaybe [CTAny] $
-      map decodeContentType . parseHttpAccept <$> lookupHeader "accept"
-  , iPayload = relevantPayload
-  , iPreferRepresentation = representation
-  , iPreferSingular = singular
-  , iPreferSingleObjectParameter = singleObject
-  , iPreferCount = not singular && hasPrefer "count=exact"
-  , iFilters = [ (toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, k /= "select", not (endingIn ["order", "limit", "offset"] k) ]
-  , iSelect = toS $ fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qParams
-  , iOrder = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["order"] k ]
-  , iCanonicalQS = toS $ urlEncodeVars
-     . L.sortBy (comparing fst)
-     . map (join (***) toS)
-     . parseSimpleQuery
-     $ rawQueryString req
-  , iJWT = tokenStr
-  }
-
  where
+  isTargetingProc = fromMaybe False $ (== "rpc") <$> listToMaybe path
+  payloadError = case payload of
+      PayloadParseError err -> err
+      _ -> ""
+  isError = case relevantPayload of
+      Just (PayloadParseError _) -> True
+      _ -> False
+  payload =
+    case decodeContentType . fromMaybe "application/json" $ lookupHeader "content-type" of
+      CTApplicationJSON ->
+        either (PayloadParseError . toS)
+          (\val -> case ensureUniform (pluralize val) of
+            Nothing -> PayloadParseError "All object keys must match"
+            Just json -> PayloadJSON json)
+          (JSON.eitherDecode reqBody)
+      CTTextCSV ->
+        either (PayloadParseError . toS)
+          (\val -> case ensureUniform (csvToJson val) of
+            Nothing -> PayloadParseError "All lines must have same number of fields"
+            Just json -> PayloadJSON json)
+          (CSV.decodeByName reqBody)
+      CTOther "application/x-www-form-urlencoded" ->
+        PayloadJSON . UniformObjects . V.singleton . M.fromList
+                    . map (toS *** JSON.String . toS) . parseSimpleQuery
+                    $ toS reqBody
+      ct ->
+        PayloadParseError $ "Content-Type not acceptable: " <> toMime ct
+  action =
+    if isTargetingProc
+      then ActionInvoke
+      else
+        case method of
+            "GET"     -> if target == TargetRoot
+                          then ActionInspect
+                          else ActionRead
+            "POST"    -> ActionCreate
+            "PATCH"   -> ActionUpdate
+            "DELETE"  -> ActionDelete
+            "OPTIONS" -> ActionInfo
+            _         -> ActionInappropriate
+  target = case path of
+              []            -> TargetRoot
+              [table]       -> TargetIdent
+                              $ QualifiedIdentifier schema table
+              ["rpc", proc] -> TargetProc
+                              $ QualifiedIdentifier schema proc
+              other         -> TargetUnknown other
+  relevantPayload = case action of
+    ActionCreate -> Just payload
+    ActionUpdate -> Just payload
+    ActionInvoke -> Just payload
+    _            -> Nothing
   path            = pathInfo req
   method          = requestMethod req
-  isTargetingProc = fromMaybe False $ (== "rpc") <$> listToMaybe path
   hdrs            = requestHeaders req
   qParams         = [(toS k, v)|(k,v) <- queryString req]
   lookupHeader    = flip lookup hdrs

src/PostgREST/App.hs

@@ -40,6 +40,7 @@ import qualified Hasql.Transaction         as H
 import qualified Data.HashMap.Strict       as M
 
 import           PostgREST.ApiRequest   ( ApiRequest(..), ContentType(..)
+                                        , ApiRequestError(..)
                                         , Action(..), Target(..)
                                         , PreferRepresentation (..)
                                         , mutuallyAgreeable
@@ -81,17 +82,23 @@ postgrest conf refDbStructure pool getTime =
     body <- strictRequestBody req
     dbStructure <- readIORef refDbStructure
 
-    let schema = toS $ configSchema conf
+    case userApiRequest (configSchema conf) req body of
-        apiRequest = userApiRequest schema req body
+      Left err -> respond $ respondToError err
-        eClaims = jwtClaims
+      Right apiRequest -> do
-          (secret <$> configJwtSecret conf) (iJWT apiRequest) time
+        let eClaims = jwtClaims
-        authed = containsRole eClaims
+              (secret <$> configJwtSecret conf) (iJWT apiRequest) time
-        handleReq = runWithClaims conf eClaims (app dbStructure conf) apiRequest
+            authed = containsRole eClaims
-        txMode = transactionMode $ iAction apiRequest
+            handleReq = runWithClaims conf eClaims (app dbStructure conf) apiRequest
+            txMode = transactionMode $ iAction apiRequest
 
-    resp <- either (pgErrResponse authed) id <$> P.use pool
+        resp <- either (pgErrResponse authed) id <$> P.use pool
-      (HT.run handleReq HT.ReadCommitted txMode)
+          (HT.run handleReq HT.ReadCommitted txMode)
-    respond resp
+        respond resp
+  where
+    respondToError error =
+      case error of
+        ErrorActionInappropriate -> errResponse status405 "Bad Request"
+        ErrorInvalidBody errorMessage -> errResponse status400 $ toS errorMessage
 
 transactionMode :: Action -> H.Mode
 transactionMode ActionRead = HT.Read

src/PostgREST/Types.hs

@@ -2,7 +2,6 @@ module PostgREST.Types where
 import           Protolude
 import qualified GHC.Show
 import           Data.Aeson
-import qualified Data.ByteString      as BS
 import qualified Data.ByteString.Lazy as BL
 import           Data.Tree
 import qualified Data.Vector          as V
@@ -112,7 +111,7 @@ unUniformObjects (UniformObjects objs) = objs
 -- have a special payload just for CSV, but until
 -- then CSV is converted to a JSON array.
 data Payload = PayloadJSON UniformObjects
-             | PayloadParseError BS.ByteString
+             | PayloadParseError ByteString
              deriving (Show, Eq)
 
 data Proxy = Proxy {