diff --git a/CHANGELOG.md b/CHANGELOG.md index 52af48693..4ef53efb7 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/main/Main.hs b/main/Main.hs index e3a4dc8b6..4e42bc975 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -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 "." "=" - diff --git a/src/PostgREST/ApiRequest.hs b/src/PostgREST/ApiRequest.hs index ad8539b1d..857d718e9 100644 --- a/src/PostgREST/ApiRequest.hs +++ b/src/PostgREST/ApiRequest.hs @@ -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 diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 6cb4e7a21..76cfff275 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -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 diff --git a/src/PostgREST/DbRequestBuilder.hs b/src/PostgREST/DbRequestBuilder.hs index 5cd9f75fd..0e276b694 100644 --- a/src/PostgREST/DbRequestBuilder.hs +++ b/src/PostgREST/DbRequestBuilder.hs @@ -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] diff --git a/src/PostgREST/Error.hs b/src/PostgREST/Error.hs index c76711f3a..dbb8ba485 100644 --- a/src/PostgREST/Error.hs +++ b/src/PostgREST/Error.hs @@ -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 diff --git a/src/PostgREST/Middleware.hs b/src/PostgREST/Middleware.hs index 0c70f8887..b53adfe82 100644 --- a/src/PostgREST/Middleware.hs +++ b/src/PostgREST/Middleware.hs @@ -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)) diff --git a/src/PostgREST/OpenAPI.hs b/src/PostgREST/OpenAPI.hs index 4cd0974e4..2a21273a2 100644 --- a/src/PostgREST/OpenAPI.hs +++ b/src/PostgREST/OpenAPI.hs @@ -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 diff --git a/src/PostgREST/Parsers.hs b/src/PostgREST/Parsers.hs index 2c50b53d5..aa1714ab4 100644 --- a/src/PostgREST/Parsers.hs +++ b/src/PostgREST/Parsers.hs @@ -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) diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs index 53a7e1c7a..d3160db0a 100644 --- a/src/PostgREST/Types.hs +++ b/src/PostgREST/Types.hs @@ -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 diff --git a/test/Feature/QuerySpec.hs b/test/Feature/QuerySpec.hs index 8a897bfc3..32648dbd6 100644 --- a/test/Feature/QuerySpec.hs +++ b/test/Feature/QuerySpec.hs @@ -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}]}] |]