Refactor error type and fix nested error message [fix #791] (#829)

2017-03-12 22:02:13 -07:00
parent 2aabbbae58
commit 206ab163b6
11 changed files with 157 additions and 129 deletions
@@ -10,6 +10,7 @@ This project adheres to [Semantic Versioning](http://semver.org/).

 ### Fixed

+- #791, malformed nested JSON error - @diogob
 - Resource embedding in views referencing tables in public schema - @fab1an

 ## [0.4.0.0] - 2017-01-19
@@ -9,7 +9,7 @@ import           PostgREST.Config                     (AppConfig (..),
                                                       minimumPgVersion,
                                                       prettyVersion,
                                                       readOptions)
-import           PostgREST.Error                      (prettyUsageError)
+import           PostgREST.Error                      (encodeError)
 import           PostgREST.OpenAPI                    (isMalformedProxyUri)
 import           PostgREST.DbStructure

@@ -74,7 +74,7 @@ main = do
    getDbStructure (toS $ configSchema conf)

  forM_ (lefts [result]) $ \e -> do
-    hPutStrLn stderr (prettyUsageError e)
+    hPutStrLn stderr (toS $ encodeError e)
    exitFailure

  refDbStructure <- newIORef $ either (panic . show) id result
@@ -124,4 +124,3 @@ loadSecretFile conf = extractAndTransform mSecret
    setSecret bs = conf { configJwtSecret = Just bs }

    replaceUrlChars = replace "_" "/" . replace "-" "+" . replace "." "="
-        
@@ -3,15 +3,12 @@ Module      : PostgREST.ApiRequest
 Description : PostgREST functions to translate HTTP request to a domain type called ApiRequest.
 -}
 module PostgREST.ApiRequest ( ApiRequest(..)
-                            , ApiRequestError(..)
                            , ContentType(..)
                            , Action(..)
                            , Target(..)
                            , PreferRepresentation (..)
                            , mutuallyAgreeable
-                            , toHeader
                            , userApiRequest
-                            , toMime
                            ) where

 import           Protolude
@@ -29,15 +26,18 @@ import           Control.Arrow             ((***))
 import qualified Data.Text                 as T
 import qualified Data.Vector               as V
 import           Network.HTTP.Base         (urlEncodeVars)
-import           Network.HTTP.Types.Header (hAuthorization, hContentType, Header)
+import           Network.HTTP.Types.Header (hAuthorization)
 import           Network.HTTP.Types.URI    (parseSimpleQuery)
 import           Network.Wai               (Request (..))
 import           Network.Wai.Parse         (parseHttpAccept)
 import           PostgREST.RangeQuery      (NonnegRange, rangeRequested, restrictRange, rangeGeq, allRange, rangeLimit, rangeOffset)
 import           Data.Ranged.Boundaries
-import           PostgREST.Types           (QualifiedIdentifier (..),
-                                            Schema,
-                                            PayloadJSON(..))
+import           PostgREST.Types           ( QualifiedIdentifier (..)
+                                           , Schema
+                                           , PayloadJSON(..)
+                                           , ContentType(..)
+                                           , ApiRequestError(..)
+                                           , toMime)
 import           Data.Ranged.Ranges        (Range(..), rangeIntersection, emptyRange)

 type RequestBody = BL.ByteString
@@ -57,30 +57,6 @@ data Target = TargetIdent QualifiedIdentifier
 -- | How to return the inserted data
 data PreferRepresentation = Full | HeadersOnly | None deriving Eq
                          --
-- | Enumeration of currently supported response content types
-data ContentType = CTApplicationJSON | CTTextCSV | CTOpenAPI
-                 | CTSingularJSON | CTOctetStream
-                 | CTAny | CTOther BS.ByteString deriving Eq
-
-data ApiRequestError = ErrorActionInappropriate
-                     | ErrorInvalidBody ByteString
-                     | ErrorInvalidRange
-                     deriving (Show, Eq)
-
-- | Convert from ContentType to a full HTTP Header
-toHeader :: ContentType -> Header
-toHeader ct = (hContentType, toMime ct <> "; charset=utf-8")
-
-- | 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 CTSingularJSON    = "application/vnd.pgrst.object+json"
-toMime CTOctetStream     = "application/octet-stream"
-toMime CTAny             = "*/*"
-toMime (CTOther ct)      = ct
-
 {-|
  Describes what the user wants to do. This data type is a
  translation of the raw elements of an HTTP request into domain
@@ -120,9 +96,9 @@ data ApiRequest = ApiRequest {
 -- | Examines HTTP request and translates it into user intent.
 userApiRequest :: Schema -> Request -> RequestBody -> Either ApiRequestError ApiRequest
 userApiRequest schema req reqBody
-  | isTargetingProc && method /= "POST" = Left ErrorActionInappropriate
-  | topLevelRange == emptyRange = Left ErrorInvalidRange
-  | shouldParsePayload && isLeft payload = either (Left . ErrorInvalidBody . toS) undefined payload
+  | isTargetingProc && method /= "POST" = Left ActionInappropriate
+  | topLevelRange == emptyRange = Left InvalidRange
+  | shouldParsePayload && isLeft payload = either (Left . InvalidBody . toS) undefined payload
  | otherwise = Right ApiRequest {
      iAction = action
      , iTarget = target
@@ -33,9 +33,7 @@ import           PostgREST.ApiRequest   ( ApiRequest(..), ContentType(..)
                                        , Action(..), Target(..)
                                        , PreferRepresentation (..)
                                        , mutuallyAgreeable
-                                        , toHeader
                                        , userApiRequest
-                                        , toMime
                                        )
 import           PostgREST.Auth            (jwtClaims, containsRole)
 import           PostgREST.Config          (AppConfig (..))
@@ -44,8 +42,8 @@ import           PostgREST.DbRequestBuilder( readRequest
                                           , mutateRequest
                                           , fieldNames
                                           )
-import           PostgREST.Error           ( errResponse, pgErrResponse
-                                           , apiRequestErrResponse
+import           PostgREST.Error           ( simpleError, pgError
+                                           , apiRequestError
                                           , singularityError, binaryFieldError
                                           )
 import           PostgREST.RangeQuery      (allRange, rangeOffset)
@@ -75,7 +73,7 @@ postgrest conf refDbStructure pool getTime =
    dbStructure <- readIORef refDbStructure

    response <- case userApiRequest (configSchema conf) req body of
-      Left err -> return $ apiRequestErrResponse err
+      Left err -> return $ apiRequestError err
      Right apiRequest -> do
        let jwtSecret = binarySecret <$> configJwtSecret conf
            eClaims = jwtClaims jwtSecret (iJWT apiRequest) time
@@ -83,7 +81,7 @@ postgrest conf refDbStructure pool getTime =
            handleReq = runWithClaims conf eClaims (app dbStructure conf) apiRequest
            txMode = transactionMode $ iAction apiRequest
        response <- P.use pool $ HT.transaction HT.ReadCommitted txMode handleReq
-        return $ either (pgErrResponse authed) identity response
+        return $ either (pgError authed) identity response
    respond response

 transactionMode :: Action -> H.Mode
@@ -104,7 +102,7 @@ app dbStructure conf apiRequest =
          case partsField of
            Left errorResponse -> return errorResponse
            Right ((q, cq), bField) -> do
-              let stm = createReadStatement q cq (contentType == CTSingularJSON) shouldCount 
+              let stm = createReadStatement q cq (contentType == CTSingularJSON) shouldCount
                                            (contentType == CTTextCSV) bField
              row <- H.query () stm
              let (tableTotal, queryTotal, _ , body) = row
@@ -293,12 +291,12 @@ responseContentTypeOrError accepts action = serves contentTypesForRequest accept
      case mutuallyAgreeable sProduces cAccepts of
        Nothing -> do
          let failed = intercalate ", " $ map (toS . toMime) cAccepts
-          Left $ errResponse status415 $
+          Left $ simpleError status415 $
            "None of these Content-Types are available: " <> failed
        Just ct -> Right ct

 binaryField :: ContentType -> [FieldName] -> Either Response (Maybe FieldName)
-binaryField CTOctetStream fldNames = 
+binaryField CTOctetStream fldNames =
  if length fldNames == 1 && fieldName /= Just "*"
    then Right fieldName
    else Left binaryFieldError
@@ -15,20 +15,17 @@ import           Data.Text                 (isInfixOf, dropWhile, drop)
 import           Data.Tree
 import           Data.Either.Combinators   (mapLeft)

-import           Text.Parsec.Error
-
-import           Network.HTTP.Types.Status
 import           Network.Wai

 import           Data.Foldable (foldr1)
 import qualified Data.HashMap.Strict       as M

-import           PostgREST.ApiRequest   ( ApiRequest(..) 
+import           PostgREST.ApiRequest   ( ApiRequest(..)
                                        , PreferRepresentation(..)
                                        , Action(..), Target(..)
                                        , PreferRepresentation (..)
                                        )
-import           PostgREST.Error           (errResponse, formatParserError)
+import           PostgREST.Error           (apiRequestError)
 import           PostgREST.Parsers
 import           PostgREST.RangeQuery      (NonnegRange, restrictRange)
 import           PostgREST.QueryBuilder (getJoinConditions, sourceCTEName)
@@ -40,10 +37,10 @@ import           Unsafe                  (unsafeHead)

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

-    parseReadRequest :: Either ParseError ReadRequest
+    parseReadRequest :: Either ApiRequestError ReadRequest
    parseReadRequest = addFiltersOrdersRanges apiRequest <*>
      pRequestSelect rootName selStr
      where
@@ -80,20 +77,18 @@ readRequest maxRows allRels allProcs apiRequest  =
      _       -> allRels
      where fakeSourceRelations = mapMaybe (toSourceRelation rootTableName) allRels -- see comment in toSourceRelation

-treeRestrictRange :: Maybe Integer -> ReadRequest -> Either Text ReadRequest
+treeRestrictRange :: Maybe Integer -> ReadRequest -> Either ApiRequestError ReadRequest
 treeRestrictRange maxRows_ request = pure $ nodeRestrictRange maxRows_ `fmap` request
  where
    nodeRestrictRange :: Maybe Integer -> ReadNode -> ReadNode
    nodeRestrictRange m (q@Select {range_=r}, i) = (q{range_=restrictRange m r }, i)

-augumentRequestWithJoin :: Schema ->  [Relation] ->  ReadRequest -> Either Text ReadRequest
+augumentRequestWithJoin :: Schema ->  [Relation] ->  ReadRequest -> Either ApiRequestError ReadRequest
 augumentRequestWithJoin schema allRels request =
-  (first formatRelationError . addRelations schema allRels Nothing) request
+  addRelations schema allRels Nothing request
  >>= addJoinConditions schema
-  where
-    formatRelationError = ("could not find foreign keys between these entities, " <>)

-addRelations :: Schema -> [Relation] -> Maybe ReadRequest -> ReadRequest -> Either Text ReadRequest
+addRelations :: Schema -> [Relation] -> Maybe ReadRequest -> ReadRequest -> Either ApiRequestError ReadRequest
 addRelations schema allRelations parentNode (Node readNode@(query, (name, _, alias)) forest) =
  case parentNode of
    (Just (Node (Select{from=[parentNodeTable]}, (_, _, _)) _)) ->
@@ -102,8 +97,8 @@ addRelations schema allRelations parentNode (Node readNode@(query, (name, _, ali
        forest' = updateForest $ hush node'
        node' = Node <$> readNode' <*> pure forest
        readNode' = addRel readNode <$> rel
-        rel :: Either Text Relation
-        rel = note ("no relation between " <> parentNodeTable <> " and " <> name)
+        rel :: Either ApiRequestError Relation
+        rel = note (NoRelationBetween parentNodeTable name)
            $ findRelation schema name parentNodeTable

            where
@@ -155,10 +150,10 @@ addRelations schema allRelations parentNode (Node readNode@(query, (name, _, ali
        t = Table schema name True -- !!! TODO find another way to get the table from the query
        r = Relation t [] t [] Root Nothing Nothing Nothing
  where
-    updateForest :: Maybe ReadRequest -> Either Text [ReadRequest]
+    updateForest :: Maybe ReadRequest -> Either ApiRequestError [ReadRequest]
    updateForest n = mapM (addRelations schema allRelations n) forest

-addJoinConditions :: Schema -> ReadRequest -> Either Text ReadRequest
+addJoinConditions :: Schema -> ReadRequest -> Either ApiRequestError ReadRequest
 addJoinConditions schema (Node nn@(query, (n, r, a)) forest) =
  case r of
    Just Relation{relType=Root} -> Node nn  <$> updatedForest -- this is the root node
@@ -169,12 +164,12 @@ addJoinConditions schema (Node nn@(query, (n, r, a)) forest) =
      where
         query' = addCond query (getJoinConditions rel)
         qq = query'{from=tableName linkTable : from query'}
-    _ -> Left "unknown relation"
+    _ -> Left UnknownRelation
  where
    updatedForest = mapM (addJoinConditions schema) forest
    addCond query' con = query'{flt_=con ++ flt_ query'}

-addFiltersOrdersRanges :: ApiRequest -> Either ParseError (ReadRequest -> ReadRequest)
+addFiltersOrdersRanges :: ApiRequest -> Either ApiRequestError (ReadRequest -> ReadRequest)
 addFiltersOrdersRanges apiRequest = foldr1 (liftA2 (.)) [
    flip (foldr addFilter) <$> filters,
    flip (foldr addOrder) <$> orders,
@@ -185,7 +180,7 @@ addFiltersOrdersRanges apiRequest = foldr1 (liftA2 (.)) [
  of type (ReadRequest->ReadRequest) that are in (Either ParseError a) context
  -}
  where
-    filters :: Either ParseError [(Path, Filter)]
+    filters :: Either ApiRequestError [(Path, Filter)]
    filters = mapM pRequestFilter flts
      where
        action = iAction apiRequest
@@ -193,9 +188,9 @@ addFiltersOrdersRanges apiRequest = foldr1 (liftA2 (.)) [
          | action == ActionRead = iFilters apiRequest
          | action == ActionInvoke = iFilters apiRequest
          | otherwise = filter (( "." `isInfixOf` ) . fst) $ iFilters apiRequest -- there can be no filters on the root table whre we are doing insert/update
-    orders :: Either ParseError [(Path, [OrderTerm])]
+    orders :: Either ApiRequestError [(Path, [OrderTerm])]
    orders = mapM pRequestOrder $ iOrder apiRequest
-    ranges :: Either ParseError [(Path, NonnegRange)]
+    ranges :: Either ApiRequestError [(Path, NonnegRange)]
    ranges = mapM pRequestRange $ M.toList $ iRange apiRequest

 addFilterToNode :: Filter -> ReadRequest -> ReadRequest
@@ -250,12 +245,12 @@ toSourceRelation mt r@(Relation t _ ft _ _ rt _ _)
  | otherwise = Nothing

 mutateRequest :: ApiRequest -> [FieldName] -> Either Response MutateRequest
-mutateRequest apiRequest fldNames = mapLeft (errResponse status400) $
+mutateRequest apiRequest fldNames = mapLeft apiRequestError $
  case action of
    ActionCreate -> Right $ Insert rootTableName payload returnings
    ActionUpdate -> Update rootTableName <$> pure payload <*> filters <*> pure returnings
    ActionDelete -> Delete rootTableName <$> filters <*> pure returnings
-    _        -> Left "Unsupported HTTP verb"
+    _        -> Left UnsupportedVerb
  where
    action = iAction apiRequest
    payload = fromJust $ iPayload apiRequest
@@ -265,7 +260,7 @@ mutateRequest apiRequest fldNames = mapLeft (errResponse status400) $
        (TargetIdent (QualifiedIdentifier _ t) ) -> t
        _ -> undefined
    returnings = if iPreferRepresentation apiRequest == None then [] else fldNames
-    filters = first formatParserError $ map snd <$> mapM pRequestFilter mutateFilters
+    filters = map snd <$> mapM pRequestFilter mutateFilters
      where mutateFilters = filter (not . ( "." `isInfixOf` ) . fst) $ iFilters apiRequest -- update/delete filters can be only on the root table

 fieldNames :: ReadRequest -> [FieldName]
@@ -3,54 +3,54 @@
 {-# LANGUAGE TypeSynonymInstances #-}

 module PostgREST.Error (
-  apiRequestErrResponse
-, pgErrResponse
-, errResponse
-, prettyUsageError
+  apiRequestError
+, pgError
+, simpleError
 , singularityError
 , binaryFieldError
-, formatGeneralError
-, formatParserError
+, encodeError
 ) where

 import           Protolude
 import           Data.Aeson                ((.=))
 import qualified Data.Aeson                as JSON
-import           Data.Text                 (replace, strip, unwords)
+import           Data.Text                 (unwords)
 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      (toHeader, toMime, ContentType(..), ApiRequestError(..))
-import           Text.Parsec.Error
+import           PostgREST.Types

-apiRequestErrResponse :: ApiRequestError -> Response
-apiRequestErrResponse err =
-  case err of
-    ErrorActionInappropriate -> errResponse HT.status405 "Bad Request"
-    ErrorInvalidBody errorMessage -> errResponse HT.status400 $ toS errorMessage
-    ErrorInvalidRange -> errResponse HT.status416 "HTTP Range error"
+apiRequestError :: ApiRequestError -> Response
+apiRequestError err = errorResponse status err
+  where
+    status =
+      case err of
+        ActionInappropriate -> HT.status405
+        UnsupportedVerb -> HT.status405
+        InvalidBody _ -> HT.status400
+        ParseRequestError _ _ -> HT.status400
+        NoRelationBetween _ _ -> HT.status400
+        InvalidRange -> HT.status416
+        UnknownRelation -> HT.status404

-errResponse :: HT.Status -> Text -> Response
-errResponse status message = jsonErrResponse status $ JSON.object ["message" .= message]
+simpleError :: HT.Status -> Text -> Response
+simpleError status message =
+  errorResponse status $ JSON.object ["message" .= message]

-jsonErrResponse :: HT.Status -> JSON.Value -> Response
-jsonErrResponse status message = responseLBS status [toHeader CTApplicationJSON] $ JSON.encode message
+errorResponse :: JSON.ToJSON a => HT.Status -> a -> Response
+errorResponse status e =
+  responseLBS status [toHeader CTApplicationJSON] $ encodeError e

-pgErrResponse :: Bool -> P.UsageError -> Response
-pgErrResponse authed e =
+pgError :: Bool -> P.UsageError -> Response
+pgError authed e =
  let status = httpStatus authed e
      jsonType = toHeader CTApplicationJSON
      wwwAuth = ("WWW-Authenticate", "Bearer")
      hdrs = if status == HT.status401
                then [jsonType, wwwAuth]
                else [jsonType] in
-  responseLBS status hdrs (JSON.encode e)
-
-prettyUsageError :: P.UsageError -> Text
-prettyUsageError (P.ConnectionError e) =
-  "Database connection error:\n" <> toS (fromMaybe "" e)
-prettyUsageError e = show $ JSON.encode e
+  responseLBS status hdrs (encodeError e)

 singularityError :: Integer -> Response
 singularityError numRows =
@@ -62,27 +62,40 @@ singularityError numRows =
        [ "Results contain", show numRows, "rows,"
        , toS (toMime CTSingularJSON), "requires 1 row"
        ]
+  where
+    formatGeneralError :: Text -> Text -> Text
+    formatGeneralError message details = toS . JSON.encode $
+      JSON.object ["message" .= message, "details" .= details]
+

 binaryFieldError :: Response
-binaryFieldError = 
-  errResponse HT.status406 (toS (toMime CTOctetStream) <>
+binaryFieldError =
+  simpleError HT.status406 (toS (toMime CTOctetStream) <>
  " requested but a single column was not selected")

-formatParserError :: ParseError -> Text
-formatParserError e = formatGeneralError message details
-  where
-     message = show $ errorPos e
-     details = strip $ replace "\n" " " $ toS
-       $ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e)
+encodeError :: JSON.ToJSON a => a -> LByteString
+encodeError = JSON.encode

-formatGeneralError :: Text -> Text -> Text
-formatGeneralError message details = toS . JSON.encode $
-  JSON.object ["message" .= message, "details" .= details]
+instance JSON.ToJSON ApiRequestError where
+  toJSON (ParseRequestError message details) = JSON.object [
+    "message" .= message, "details" .= details]
+  toJSON ActionInappropriate = JSON.object [
+    "message" .= ("Bad Request" :: Text)]
+  toJSON (InvalidBody errorMessage) = JSON.object [
+    "message" .= (toS errorMessage :: Text)]
+  toJSON InvalidRange = JSON.object [
+    "message" .= ("HTTP Range error" :: Text)]
+  toJSON UnknownRelation = JSON.object [
+    "message" .= ("Unknown relation" :: Text)]
+  toJSON (NoRelationBetween parent child) = JSON.object [
+    "message" .= ("Could not find foreign keys between these entities, No relation found between " <> parent <> " and " <> child :: Text)]
+  toJSON UnsupportedVerb = JSON.object [
+    "message" .= ("Unsupported HTTP verb" :: Text)]

 instance JSON.ToJSON P.UsageError where
  toJSON (P.ConnectionError e) = JSON.object [
    "code" .= ("" :: Text),
-    "message" .= ("Connection error" :: Text),
+    "message" .= ("Database connection error" :: Text),
    "details" .= (toS $ fromMaybe "" e :: Text)]
  toJSON (P.SessionError e) = JSON.toJSON e -- H.Error

@@ -14,11 +14,11 @@ import           Network.Wai.Middleware.Cors   (cors)
 import           Network.Wai.Middleware.Gzip   (def, gzip)
 import           Network.Wai.Middleware.Static (only, staticPolicy)

-import           PostgREST.ApiRequest          (ApiRequest(..), ContentType(..),
-                                                toHeader)
+import           PostgREST.ApiRequest          (ApiRequest(..))
 import           PostgREST.Auth                (claimsToSQL, JWTAttempt(..))
 import           PostgREST.Config              (AppConfig (..), corsPolicy)
-import           PostgREST.Error               (errResponse)
+import           PostgREST.Error               (simpleError)
+import           PostgREST.Types               (ContentType (..), toHeader)

 import           Protolude                     hiding (concat, null)

@@ -29,7 +29,7 @@ runWithClaims conf eClaims app req =
  case eClaims of
    JWTExpired -> return $ unauthed "JWT expired"
    JWTInvalid -> return $ unauthed "JWT invalid"
-    JWTMissingSecret -> return $ errResponse status500 "Server lacks JWT secret"
+    JWTMissingSecret -> return $ simpleError status500 "Server lacks JWT secret"
    JWTClaims claims -> do
      -- role claim defaults to anon if not specified in jwt
      let setClaims = claimsToSQL (M.union claims (M.singleton "role" anon))
@@ -20,11 +20,11 @@ import           Protolude hiding              (concat, (&), Proxy, get, interca

 import           Data.Swagger

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

 makeMimeList :: [ContentType] -> MimeList
 makeMimeList cs = MimeList $ map (fromString . toS . toMime) cs
@@ -2,20 +2,22 @@ module PostgREST.Parsers where

 import           Protolude                     hiding (try, intercalate)
 import           Control.Monad                ((>>))
-import           Data.Text                     (intercalate)
+import           Data.Text                     (intercalate, replace, strip)
 import           Data.List                     (init, last)
 import           Data.Tree
+import           Data.Either.Combinators       (mapLeft)
 import           PostgREST.QueryBuilder        (operators)
 import           PostgREST.Types
 import           Text.ParserCombinators.Parsec hiding (many, (<|>))
 import           PostgREST.RangeQuery      (NonnegRange,allRange)
+import           Text.Parsec.Error

-pRequestSelect :: Text -> Text -> Either ParseError ReadRequest
-pRequestSelect rootName selStr = 
-  parse (pReadRequest rootName) ("failed to parse select parameter (" <> toS selStr <> ")") (toS selStr)
+pRequestSelect :: Text -> Text -> Either ApiRequestError ReadRequest
+pRequestSelect rootName selStr =
+  mapError $ parse (pReadRequest rootName) ("failed to parse select parameter (" <> toS selStr <> ")") (toS selStr)

-pRequestFilter :: (Text, Text) -> Either ParseError (Path, Filter)
-pRequestFilter (k, v) = (,) <$> path <*> (Filter <$> fld <*> op <*> val)
+pRequestFilter :: (Text, Text) -> Either ApiRequestError (Path, Filter)
+pRequestFilter (k, v) = mapError $ (,) <$> path <*> (Filter <$> fld <*> op <*> val)
  where
    treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k
    opVal = parse pOpValueExp ("failed to parse filter (" ++ toS v ++ ")") $ toS v
@@ -24,15 +26,15 @@ pRequestFilter (k, v) = (,) <$> path <*> (Filter <$> fld <*> op <*> val)
    op = fst <$> opVal
    val = snd <$> opVal

-pRequestOrder :: (Text, Text) -> Either ParseError (Path, [OrderTerm])
-pRequestOrder (k, v) = (,) <$> path <*> ord'
+pRequestOrder :: (Text, Text) -> Either ApiRequestError (Path, [OrderTerm])
+pRequestOrder (k, v) = mapError $ (,) <$> path <*> ord'
  where
    treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k
    path = fst <$> treePath
    ord' = parse pOrder ("failed to parse order (" ++ toS v ++ ")") $ toS v

-pRequestRange :: (ByteString, NonnegRange) -> Either ParseError (Path, NonnegRange)
-pRequestRange (k, v) = (,) <$> path <*> pure v
+pRequestRange :: (ByteString, NonnegRange) -> Either ApiRequestError (Path, NonnegRange)
+pRequestRange (k, v) = mapError $ (,) <$> path <*> pure v
  where
    treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k
    path = fst <$> treePath
@@ -152,3 +154,13 @@ pOrderTerm =
    return $ OrderTerm c d nls
  )
  <|> OrderTerm <$> pField <*> pure Nothing <*> pure Nothing
+
+mapError :: Either ParseError a -> Either ApiRequestError a
+mapError = mapLeft translateError
+  where
+    translateError e =
+      ParseRequestError message details
+      where
+        message = show $ errorPos e
+        details = strip $ replace "\n" " " $ toS
+           $ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e)
@@ -6,6 +6,21 @@ import qualified Data.ByteString.Lazy as BL
 import           Data.Tree
 import qualified Data.Vector          as V
 import           PostgREST.RangeQuery (NonnegRange)
+import           Network.HTTP.Types.Header (hContentType, Header)
+
+-- | Enumeration of currently supported response content types
+data ContentType = CTApplicationJSON | CTTextCSV | CTOpenAPI
+                 | CTSingularJSON | CTOctetStream
+                 | CTAny | CTOther ByteString deriving Eq
+
+data ApiRequestError = ActionInappropriate
+                     | InvalidBody ByteString
+                     | InvalidRange
+                     | ParseRequestError Text Text
+                     | UnknownRelation
+                     | NoRelationBetween Text Text
+                     | UnsupportedVerb
+                     deriving (Show, Eq)

 data DbStructure = DbStructure {
  dbTables      :: [Table]
@@ -134,7 +149,6 @@ type ReadRequest = Tree ReadNode
 type MutateRequest = MutateQuery
 data DbRequest = DbRead ReadRequest | DbMutate MutateRequest

-
 instance ToJSON Column where
  toJSON c = object [
      "schema"    .= tableSchema t
@@ -172,3 +186,17 @@ instance Eq Table where
 instance Eq Column where
  Column{colTable=t1,colName=n1} == Column{colTable=t2,colName=n2} = t1 == t2 && n1 == n2
  _ == _ = False
+
+-- | Convert from ContentType to a full HTTP Header
+toHeader :: ContentType -> Header
+toHeader ct = (hContentType, toMime ct <> "; charset=utf-8")
+
+-- | 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 CTSingularJSON    = "application/vnd.pgrst.object+json"
+toMime CTOctetStream     = "application/octet-stream"
+toMime CTAny             = "*/*"
+toMime (CTOther ct)      = ct
@@ -119,7 +119,7 @@ spec = do

    it "matches filtering nested items 2" $
      get "/clients?select=id,projects{id,tasks2{id,name}}&projects.tasks.name=like.Design*"
-        `shouldRespondWith` [json| {"message":"could not find foreign keys between these entities, no relation between projects and tasks2"}|]
+        `shouldRespondWith` [json| {"message":"Could not find foreign keys between these entities, No relation found between projects and tasks2"}|]
        { matchStatus  = 400
        , matchHeaders = [matchContentTypeJson]
        }
@@ -600,6 +600,12 @@ spec = do
        [json| [{"escapeId":1},{"escapeId":3},{"escapeId":5}] |]
        { matchHeaders = [matchContentTypeJson] }

+    it "fails if an operator is not given" $
+      get "/ghostBusters?id=0" `shouldRespondWith` [json| {"details":"unexpected \"0\" expecting \"not.\" or operator (eq, gt, ...)","message":"\"failed to parse filter (0)\" (line 1, column 1)"} |]
+        { matchStatus  = 400
+        , matchHeaders = [matchContentTypeJson]
+        }
+
    it "will embed a collection" $
      get "/Escap3e;?select=ghostBusters{*}" `shouldRespondWith`
        [json| [{"ghostBusters":[{"escapeId":1}]},{"ghostBusters":[]},{"ghostBusters":[{"escapeId":3}]},{"ghostBusters":[]},{"ghostBusters":[{"escapeId":5}]}] |]