jimmy/postgrest
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
Diogo Biazus
2017-03-12 22:02:13 -07:00
committed by Joe Nelson
parent 2aabbbae58
commit 206ab163b6
11 changed files with 157 additions and 129 deletions
Download Patch File Download Diff File Expand all files Collapse all files
CHANGELOG.md
+1
View File
@@ -10,6 +10,7 @@ This project adheres to [Semantic Versioning](http://semver.org/).
### Fixed ### Fixed
- #791, malformed nested JSON error - @diogob
- Resource embedding in views referencing tables in public schema - @fab1an - Resource embedding in views referencing tables in public schema - @fab1an
## [0.4.0.0] - 2017-01-19 ## [0.4.0.0] - 2017-01-19
main/Main.hs
+2 -3
View File
@@ -9,7 +9,7 @@ import PostgREST.Config (AppConfig (..),
minimumPgVersion, minimumPgVersion,
prettyVersion, prettyVersion,
readOptions) readOptions)
import PostgREST.Error (prettyUsageError) import PostgREST.Error (encodeError)
import PostgREST.OpenAPI (isMalformedProxyUri) import PostgREST.OpenAPI (isMalformedProxyUri)
import PostgREST.DbStructure import PostgREST.DbStructure
@@ -74,7 +74,7 @@ main = do
getDbStructure (toS $ configSchema conf) getDbStructure (toS $ configSchema conf)
forM_ (lefts [result]) $ \e -> do forM_ (lefts [result]) $ \e -> do
hPutStrLn stderr (prettyUsageError e) hPutStrLn stderr (toS $ encodeError e)
exitFailure exitFailure
refDbStructure <- newIORef $ either (panic . show) id result refDbStructure <- newIORef $ either (panic . show) id result
@@ -124,4 +124,3 @@ loadSecretFile conf = extractAndTransform mSecret
setSecret bs = conf { configJwtSecret = Just bs } setSecret bs = conf { configJwtSecret = Just bs }
replaceUrlChars = replace "_" "/" . replace "-" "+" . replace "." "=" replaceUrlChars = replace "_" "/" . replace "-" "+" . replace "." "="
src/PostgREST/ApiRequest.hs
+10 -34
View File
@@ -3,15 +3,12 @@ Module : PostgREST.ApiRequest
Description : PostgREST functions to translate HTTP request to a domain type called ApiRequest. Description : PostgREST functions to translate HTTP request to a domain type called ApiRequest.
-} -}
module PostgREST.ApiRequest ( ApiRequest(..) module PostgREST.ApiRequest ( ApiRequest(..)
, ApiRequestError(..)
, ContentType(..) , ContentType(..)
, Action(..) , Action(..)
, Target(..) , Target(..)
, PreferRepresentation (..) , PreferRepresentation (..)
, mutuallyAgreeable , mutuallyAgreeable
, toHeader
, userApiRequest , userApiRequest
, toMime
) where ) where
import Protolude import Protolude
@@ -29,15 +26,18 @@ import Control.Arrow ((***))
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Vector as V import qualified Data.Vector as V
import Network.HTTP.Base (urlEncodeVars) 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.HTTP.Types.URI (parseSimpleQuery)
import Network.Wai (Request (..)) import Network.Wai (Request (..))
import Network.Wai.Parse (parseHttpAccept) import Network.Wai.Parse (parseHttpAccept)
import PostgREST.RangeQuery (NonnegRange, rangeRequested, restrictRange, rangeGeq, allRange, rangeLimit, rangeOffset) import PostgREST.RangeQuery (NonnegRange, rangeRequested, restrictRange, rangeGeq, allRange, rangeLimit, rangeOffset)
import Data.Ranged.Boundaries import Data.Ranged.Boundaries
import PostgREST.Types (QualifiedIdentifier (..), import PostgREST.Types ( QualifiedIdentifier (..)
Schema, , Schema
PayloadJSON(..)) , PayloadJSON(..)
, ContentType(..)
, ApiRequestError(..)
, toMime)
import Data.Ranged.Ranges (Range(..), rangeIntersection, emptyRange) import Data.Ranged.Ranges (Range(..), rangeIntersection, emptyRange)
type RequestBody = BL.ByteString type RequestBody = BL.ByteString
@@ -57,30 +57,6 @@ data Target = TargetIdent QualifiedIdentifier
-- | How to return the inserted data -- | How to return the inserted data
data PreferRepresentation = Full | HeadersOnly | None deriving Eq 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 Describes what the user wants to do. This data type is a
translation of the raw elements of an HTTP request into domain 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. -- | Examines HTTP request and translates it into user intent.
userApiRequest :: Schema -> Request -> RequestBody -> Either ApiRequestError ApiRequest userApiRequest :: Schema -> Request -> RequestBody -> Either ApiRequestError ApiRequest
userApiRequest schema req reqBody userApiRequest schema req reqBody
| isTargetingProc && method /= "POST" = Left ErrorActionInappropriate | isTargetingProc && method /= "POST" = Left ActionInappropriate
| topLevelRange == emptyRange = Left ErrorInvalidRange | topLevelRange == emptyRange = Left InvalidRange
| shouldParsePayload && isLeft payload = either (Left . ErrorInvalidBody . toS) undefined payload | shouldParsePayload && isLeft payload = either (Left . InvalidBody . toS) undefined payload
| otherwise = Right ApiRequest { | otherwise = Right ApiRequest {
iAction = action iAction = action
, iTarget = target , iTarget = target
src/PostgREST/App.hs
+5 -7
View File
@@ -33,9 +33,7 @@ import PostgREST.ApiRequest ( ApiRequest(..), ContentType(..)
, Action(..), Target(..) , Action(..), Target(..)
, PreferRepresentation (..) , PreferRepresentation (..)
, mutuallyAgreeable , mutuallyAgreeable
, toHeader
, userApiRequest , userApiRequest
, toMime
) )
import PostgREST.Auth (jwtClaims, containsRole) import PostgREST.Auth (jwtClaims, containsRole)
import PostgREST.Config (AppConfig (..)) import PostgREST.Config (AppConfig (..))
@@ -44,8 +42,8 @@ import PostgREST.DbRequestBuilder( readRequest
, mutateRequest , mutateRequest
, fieldNames , fieldNames
) )
import PostgREST.Error ( errResponse, pgErrResponse import PostgREST.Error ( simpleError, pgError
, apiRequestErrResponse , apiRequestError
, singularityError, binaryFieldError , singularityError, binaryFieldError
) )
import PostgREST.RangeQuery (allRange, rangeOffset) import PostgREST.RangeQuery (allRange, rangeOffset)
@@ -75,7 +73,7 @@ postgrest conf refDbStructure pool getTime =
dbStructure <- readIORef refDbStructure dbStructure <- readIORef refDbStructure
response <- case userApiRequest (configSchema conf) req body of response <- case userApiRequest (configSchema conf) req body of
Left err -> return $ apiRequestErrResponse err Left err -> return $ apiRequestError err
Right apiRequest -> do Right apiRequest -> do
let jwtSecret = binarySecret <$> configJwtSecret conf let jwtSecret = binarySecret <$> configJwtSecret conf
eClaims = jwtClaims jwtSecret (iJWT apiRequest) time eClaims = jwtClaims jwtSecret (iJWT apiRequest) time
@@ -83,7 +81,7 @@ postgrest conf refDbStructure pool getTime =
handleReq = runWithClaims conf eClaims (app dbStructure conf) apiRequest handleReq = runWithClaims conf eClaims (app dbStructure conf) apiRequest
txMode = transactionMode $ iAction apiRequest txMode = transactionMode $ iAction apiRequest
response <- P.use pool $ HT.transaction HT.ReadCommitted txMode handleReq response <- P.use pool $ HT.transaction HT.ReadCommitted txMode handleReq
return $ either (pgErrResponse authed) identity response return $ either (pgError authed) identity response
respond response respond response
transactionMode :: Action -> H.Mode transactionMode :: Action -> H.Mode
@@ -293,7 +291,7 @@ responseContentTypeOrError accepts action = serves contentTypesForRequest accept
case mutuallyAgreeable sProduces cAccepts of case mutuallyAgreeable sProduces cAccepts of
Nothing -> do Nothing -> do
let failed = intercalate ", " $ map (toS . toMime) cAccepts let failed = intercalate ", " $ map (toS . toMime) cAccepts
Left $ errResponse status415 $ Left $ simpleError status415 $
"None of these Content-Types are available: " <> failed "None of these Content-Types are available: " <> failed
Just ct -> Right ct Just ct -> Right ct
src/PostgREST/DbRequestBuilder.hs
+20 -25
View File
@@ -15,9 +15,6 @@ import Data.Text (isInfixOf, dropWhile, drop)
import Data.Tree import Data.Tree
import Data.Either.Combinators (mapLeft) import Data.Either.Combinators (mapLeft)
import Text.Parsec.Error
import Network.HTTP.Types.Status
import Network.Wai import Network.Wai
import Data.Foldable (foldr1) import Data.Foldable (foldr1)
@@ -28,7 +25,7 @@ import PostgREST.ApiRequest ( ApiRequest(..)
, Action(..), Target(..) , Action(..), Target(..)
, PreferRepresentation (..) , PreferRepresentation (..)
) )
import PostgREST.Error (errResponse, formatParserError) import PostgREST.Error (apiRequestError)
import PostgREST.Parsers import PostgREST.Parsers
import PostgREST.RangeQuery (NonnegRange, restrictRange) import PostgREST.RangeQuery (NonnegRange, restrictRange)
import PostgREST.QueryBuilder (getJoinConditions, sourceCTEName) import PostgREST.QueryBuilder (getJoinConditions, sourceCTEName)
@@ -40,10 +37,10 @@ import Unsafe (unsafeHead)
readRequest :: Maybe Integer -> [Relation] -> [(Text, Text)] -> ApiRequest -> Either Response ReadRequest readRequest :: Maybe Integer -> [Relation] -> [(Text, Text)] -> ApiRequest -> Either Response ReadRequest
readRequest maxRows allRels allProcs apiRequest = readRequest maxRows allRels allProcs apiRequest =
mapLeft (errResponse status400) $ mapLeft apiRequestError $
treeRestrictRange maxRows =<< treeRestrictRange maxRows =<<
augumentRequestWithJoin schema relations =<< augumentRequestWithJoin schema relations =<<
first formatParserError parseReadRequest parseReadRequest
where where
(schema, rootTableName) = fromJust $ -- Make it safe (schema, rootTableName) = fromJust $ -- Make it safe
let target = iTarget apiRequest in let target = iTarget apiRequest in
@@ -62,7 +59,7 @@ readRequest maxRows allRels allProcs apiRequest =
action :: Action action :: Action
action = iAction apiRequest action = iAction apiRequest
parseReadRequest :: Either ParseError ReadRequest parseReadRequest :: Either ApiRequestError ReadRequest
parseReadRequest = addFiltersOrdersRanges apiRequest <*> parseReadRequest = addFiltersOrdersRanges apiRequest <*>
pRequestSelect rootName selStr pRequestSelect rootName selStr
where where
@@ -80,20 +77,18 @@ readRequest maxRows allRels allProcs apiRequest =
_ -> allRels _ -> allRels
where fakeSourceRelations = mapMaybe (toSourceRelation rootTableName) allRels -- see comment in toSourceRelation 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 treeRestrictRange maxRows_ request = pure $ nodeRestrictRange maxRows_ `fmap` request
where where
nodeRestrictRange :: Maybe Integer -> ReadNode -> ReadNode nodeRestrictRange :: Maybe Integer -> ReadNode -> ReadNode
nodeRestrictRange m (q@Select {range_=r}, i) = (q{range_=restrictRange m r }, i) 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 = augumentRequestWithJoin schema allRels request =
(first formatRelationError . addRelations schema allRels Nothing) request addRelations schema allRels Nothing request
>>= addJoinConditions schema >>= 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) = addRelations schema allRelations parentNode (Node readNode@(query, (name, _, alias)) forest) =
case parentNode of case parentNode of
(Just (Node (Select{from=[parentNodeTable]}, (_, _, _)) _)) -> (Just (Node (Select{from=[parentNodeTable]}, (_, _, _)) _)) ->
@@ -102,8 +97,8 @@ addRelations schema allRelations parentNode (Node readNode@(query, (name, _, ali
forest' = updateForest $ hush node' forest' = updateForest $ hush node'
node' = Node <$> readNode' <*> pure forest node' = Node <$> readNode' <*> pure forest
readNode' = addRel readNode <$> rel readNode' = addRel readNode <$> rel
rel :: Either Text Relation rel :: Either ApiRequestError Relation
rel = note ("no relation between " <> parentNodeTable <> " and " <> name) rel = note (NoRelationBetween parentNodeTable name)
$ findRelation schema name parentNodeTable $ findRelation schema name parentNodeTable
where 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 t = Table schema name True -- !!! TODO find another way to get the table from the query
r = Relation t [] t [] Root Nothing Nothing Nothing r = Relation t [] t [] Root Nothing Nothing Nothing
where where
updateForest :: Maybe ReadRequest -> Either Text [ReadRequest] updateForest :: Maybe ReadRequest -> Either ApiRequestError [ReadRequest]
updateForest n = mapM (addRelations schema allRelations n) forest 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) = addJoinConditions schema (Node nn@(query, (n, r, a)) forest) =
case r of case r of
Just Relation{relType=Root} -> Node nn <$> updatedForest -- this is the root node 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 where
query' = addCond query (getJoinConditions rel) query' = addCond query (getJoinConditions rel)
qq = query'{from=tableName linkTable : from query'} qq = query'{from=tableName linkTable : from query'}
_ -> Left "unknown relation" _ -> Left UnknownRelation
where where
updatedForest = mapM (addJoinConditions schema) forest updatedForest = mapM (addJoinConditions schema) forest
addCond query' con = query'{flt_=con ++ flt_ query'} addCond query' con = query'{flt_=con ++ flt_ query'}
addFiltersOrdersRanges :: ApiRequest -> Either ParseError (ReadRequest -> ReadRequest) addFiltersOrdersRanges :: ApiRequest -> Either ApiRequestError (ReadRequest -> ReadRequest)
addFiltersOrdersRanges apiRequest = foldr1 (liftA2 (.)) [ addFiltersOrdersRanges apiRequest = foldr1 (liftA2 (.)) [
flip (foldr addFilter) <$> filters, flip (foldr addFilter) <$> filters,
flip (foldr addOrder) <$> orders, flip (foldr addOrder) <$> orders,
@@ -185,7 +180,7 @@ addFiltersOrdersRanges apiRequest = foldr1 (liftA2 (.)) [
of type (ReadRequest->ReadRequest) that are in (Either ParseError a) context of type (ReadRequest->ReadRequest) that are in (Either ParseError a) context
-} -}
where where
filters :: Either ParseError [(Path, Filter)] filters :: Either ApiRequestError [(Path, Filter)]
filters = mapM pRequestFilter flts filters = mapM pRequestFilter flts
where where
action = iAction apiRequest action = iAction apiRequest
@@ -193,9 +188,9 @@ addFiltersOrdersRanges apiRequest = foldr1 (liftA2 (.)) [
| action == ActionRead = iFilters apiRequest | action == ActionRead = iFilters apiRequest
| action == ActionInvoke = 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 | 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 orders = mapM pRequestOrder $ iOrder apiRequest
ranges :: Either ParseError [(Path, NonnegRange)] ranges :: Either ApiRequestError [(Path, NonnegRange)]
ranges = mapM pRequestRange $ M.toList $ iRange apiRequest ranges = mapM pRequestRange $ M.toList $ iRange apiRequest
addFilterToNode :: Filter -> ReadRequest -> ReadRequest addFilterToNode :: Filter -> ReadRequest -> ReadRequest
@@ -250,12 +245,12 @@ toSourceRelation mt r@(Relation t _ ft _ _ rt _ _)
| otherwise = Nothing | otherwise = Nothing
mutateRequest :: ApiRequest -> [FieldName] -> Either Response MutateRequest mutateRequest :: ApiRequest -> [FieldName] -> Either Response MutateRequest
mutateRequest apiRequest fldNames = mapLeft (errResponse status400) $ mutateRequest apiRequest fldNames = mapLeft apiRequestError $
case action of case action of
ActionCreate -> Right $ Insert rootTableName payload returnings ActionCreate -> Right $ Insert rootTableName payload returnings
ActionUpdate -> Update rootTableName <$> pure payload <*> filters <*> pure returnings ActionUpdate -> Update rootTableName <$> pure payload <*> filters <*> pure returnings
ActionDelete -> Delete rootTableName <$> filters <*> pure returnings ActionDelete -> Delete rootTableName <$> filters <*> pure returnings
_ -> Left "Unsupported HTTP verb" _ -> Left UnsupportedVerb
where where
action = iAction apiRequest action = iAction apiRequest
payload = fromJust $ iPayload apiRequest payload = fromJust $ iPayload apiRequest
@@ -265,7 +260,7 @@ mutateRequest apiRequest fldNames = mapLeft (errResponse status400) $
(TargetIdent (QualifiedIdentifier _ t) ) -> t (TargetIdent (QualifiedIdentifier _ t) ) -> t
_ -> undefined _ -> undefined
returnings = if iPreferRepresentation apiRequest == None then [] else fldNames 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 where mutateFilters = filter (not . ( "." `isInfixOf` ) . fst) $ iFilters apiRequest -- update/delete filters can be only on the root table
fieldNames :: ReadRequest -> [FieldName] fieldNames :: ReadRequest -> [FieldName]
src/PostgREST/Error.hs
+51 -38
View File
@@ -3,54 +3,54 @@
{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE TypeSynonymInstances #-}
module PostgREST.Error ( module PostgREST.Error (
apiRequestErrResponse apiRequestError
, pgErrResponse , pgError
, errResponse , simpleError
, prettyUsageError
, singularityError , singularityError
, binaryFieldError , binaryFieldError
, formatGeneralError , encodeError
, formatParserError
) where ) where
import Protolude import Protolude
import Data.Aeson ((.=)) import Data.Aeson ((.=))
import qualified Data.Aeson as JSON 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.Pool as P
import qualified Hasql.Session as H import qualified Hasql.Session as H
import qualified Network.HTTP.Types.Status as HT import qualified Network.HTTP.Types.Status as HT
import Network.Wai (Response, responseLBS) import Network.Wai (Response, responseLBS)
import PostgREST.ApiRequest (toHeader, toMime, ContentType(..), ApiRequestError(..)) import PostgREST.Types
import Text.Parsec.Error
apiRequestErrResponse :: ApiRequestError -> Response apiRequestError :: ApiRequestError -> Response
apiRequestErrResponse err = apiRequestError err = errorResponse status err
case err of where
ErrorActionInappropriate -> errResponse HT.status405 "Bad Request" status =
ErrorInvalidBody errorMessage -> errResponse HT.status400 $ toS errorMessage case err of
ErrorInvalidRange -> errResponse HT.status416 "HTTP Range error" 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 simpleError :: HT.Status -> Text -> Response
errResponse status message = jsonErrResponse status $ JSON.object ["message" .= message] simpleError status message =
errorResponse status $ JSON.object ["message" .= message]
jsonErrResponse :: HT.Status -> JSON.Value -> Response errorResponse :: JSON.ToJSON a => HT.Status -> a -> Response
jsonErrResponse status message = responseLBS status [toHeader CTApplicationJSON] $ JSON.encode message errorResponse status e =
responseLBS status [toHeader CTApplicationJSON] $ encodeError e
pgErrResponse :: Bool -> P.UsageError -> Response pgError :: Bool -> P.UsageError -> Response
pgErrResponse authed e = pgError authed e =
let status = httpStatus authed e let status = httpStatus authed e
jsonType = toHeader CTApplicationJSON jsonType = toHeader CTApplicationJSON
wwwAuth = ("WWW-Authenticate", "Bearer") wwwAuth = ("WWW-Authenticate", "Bearer")
hdrs = if status == HT.status401 hdrs = if status == HT.status401
then [jsonType, wwwAuth] then [jsonType, wwwAuth]
else [jsonType] in else [jsonType] in
responseLBS status hdrs (JSON.encode e) responseLBS status hdrs (encodeError e)
prettyUsageError :: P.UsageError -> Text
prettyUsageError (P.ConnectionError e) =
"Database connection error:\n" <> toS (fromMaybe "" e)
prettyUsageError e = show $ JSON.encode e
singularityError :: Integer -> Response singularityError :: Integer -> Response
singularityError numRows = singularityError numRows =
@@ -62,27 +62,40 @@ singularityError numRows =
[ "Results contain", show numRows, "rows," [ "Results contain", show numRows, "rows,"
, toS (toMime CTSingularJSON), "requires 1 row" , 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 :: Response
binaryFieldError = binaryFieldError =
errResponse HT.status406 (toS (toMime CTOctetStream) <> simpleError HT.status406 (toS (toMime CTOctetStream) <>
" requested but a single column was not selected") " requested but a single column was not selected")
formatParserError :: ParseError -> Text encodeError :: JSON.ToJSON a => a -> LByteString
formatParserError e = formatGeneralError message details encodeError = JSON.encode
where
message = show $ errorPos e
details = strip $ replace "\n" " " $ toS
$ showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" (errorMessages e)
formatGeneralError :: Text -> Text -> Text instance JSON.ToJSON ApiRequestError where
formatGeneralError message details = toS . JSON.encode $ toJSON (ParseRequestError message details) = JSON.object [
JSON.object ["message" .= message, "details" .= details] "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 instance JSON.ToJSON P.UsageError where
toJSON (P.ConnectionError e) = JSON.object [ toJSON (P.ConnectionError e) = JSON.object [
"code" .= ("" :: Text), "code" .= ("" :: Text),
"message" .= ("Connection error" :: Text), "message" .= ("Database connection error" :: Text),
"details" .= (toS $ fromMaybe "" e :: Text)] "details" .= (toS $ fromMaybe "" e :: Text)]
toJSON (P.SessionError e) = JSON.toJSON e -- H.Error toJSON (P.SessionError e) = JSON.toJSON e -- H.Error
src/PostgREST/Middleware.hs
+4 -4
View File
@@ -14,11 +14,11 @@ import Network.Wai.Middleware.Cors (cors)
import Network.Wai.Middleware.Gzip (def, gzip) import Network.Wai.Middleware.Gzip (def, gzip)
import Network.Wai.Middleware.Static (only, staticPolicy) import Network.Wai.Middleware.Static (only, staticPolicy)
import PostgREST.ApiRequest (ApiRequest(..), ContentType(..), import PostgREST.ApiRequest (ApiRequest(..))
toHeader)
import PostgREST.Auth (claimsToSQL, JWTAttempt(..)) import PostgREST.Auth (claimsToSQL, JWTAttempt(..))
import PostgREST.Config (AppConfig (..), corsPolicy) import PostgREST.Config (AppConfig (..), corsPolicy)
import PostgREST.Error (errResponse) import PostgREST.Error (simpleError)
import PostgREST.Types (ContentType (..), toHeader)
import Protolude hiding (concat, null) import Protolude hiding (concat, null)
@@ -29,7 +29,7 @@ runWithClaims conf eClaims app req =
case eClaims of case eClaims of
JWTExpired -> return $ unauthed "JWT expired" JWTExpired -> return $ unauthed "JWT expired"
JWTInvalid -> return $ unauthed "JWT invalid" JWTInvalid -> return $ unauthed "JWT invalid"
JWTMissingSecret -> return $ errResponse status500 "Server lacks JWT secret" JWTMissingSecret -> return $ simpleError status500 "Server lacks JWT secret"
JWTClaims claims -> do JWTClaims claims -> do
-- role claim defaults to anon if not specified in jwt -- role claim defaults to anon if not specified in jwt
let setClaims = claimsToSQL (M.union claims (M.singleton "role" anon)) let setClaims = claimsToSQL (M.union claims (M.singleton "role" anon))
src/PostgREST/OpenAPI.hs
+2 -2
View File
@@ -20,11 +20,11 @@ import Protolude hiding (concat, (&), Proxy, get, interca
import Data.Swagger import Data.Swagger
import PostgREST.ApiRequest (ContentType(..), toMime) import PostgREST.ApiRequest (ContentType(..))
import PostgREST.Config (prettyVersion) import PostgREST.Config (prettyVersion)
import PostgREST.QueryBuilder (operators) import PostgREST.QueryBuilder (operators)
import PostgREST.Types (Table(..), Column(..), PgArg(..), import PostgREST.Types (Table(..), Column(..), PgArg(..),
Proxy(..), ProcDescription(..)) Proxy(..), ProcDescription(..), toMime)
makeMimeList :: [ContentType] -> MimeList makeMimeList :: [ContentType] -> MimeList
makeMimeList cs = MimeList $ map (fromString . toS . toMime) cs makeMimeList cs = MimeList $ map (fromString . toS . toMime) cs
src/PostgREST/Parsers.hs
+21 -9
View File
@@ -2,20 +2,22 @@ module PostgREST.Parsers where
import Protolude hiding (try, intercalate) import Protolude hiding (try, intercalate)
import Control.Monad ((>>)) import Control.Monad ((>>))
import Data.Text (intercalate) import Data.Text (intercalate, replace, strip)
import Data.List (init, last) import Data.List (init, last)
import Data.Tree import Data.Tree
import Data.Either.Combinators (mapLeft)
import PostgREST.QueryBuilder (operators) import PostgREST.QueryBuilder (operators)
import PostgREST.Types import PostgREST.Types
import Text.ParserCombinators.Parsec hiding (many, (<|>)) import Text.ParserCombinators.Parsec hiding (many, (<|>))
import PostgREST.RangeQuery (NonnegRange,allRange) import PostgREST.RangeQuery (NonnegRange,allRange)
import Text.Parsec.Error
pRequestSelect :: Text -> Text -> Either ParseError ReadRequest pRequestSelect :: Text -> Text -> Either ApiRequestError ReadRequest
pRequestSelect rootName selStr = pRequestSelect rootName selStr =
parse (pReadRequest rootName) ("failed to parse select parameter (" <> toS selStr <> ")") (toS selStr) mapError $ parse (pReadRequest rootName) ("failed to parse select parameter (" <> toS selStr <> ")") (toS selStr)
pRequestFilter :: (Text, Text) -> Either ParseError (Path, Filter) pRequestFilter :: (Text, Text) -> Either ApiRequestError (Path, Filter)
pRequestFilter (k, v) = (,) <$> path <*> (Filter <$> fld <*> op <*> val) pRequestFilter (k, v) = mapError $ (,) <$> path <*> (Filter <$> fld <*> op <*> val)
where where
treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k
opVal = parse pOpValueExp ("failed to parse filter (" ++ toS v ++ ")") $ toS v 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 op = fst <$> opVal
val = snd <$> opVal val = snd <$> opVal
pRequestOrder :: (Text, Text) -> Either ParseError (Path, [OrderTerm]) pRequestOrder :: (Text, Text) -> Either ApiRequestError (Path, [OrderTerm])
pRequestOrder (k, v) = (,) <$> path <*> ord' pRequestOrder (k, v) = mapError $ (,) <$> path <*> ord'
where where
treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k
path = fst <$> treePath path = fst <$> treePath
ord' = parse pOrder ("failed to parse order (" ++ toS v ++ ")") $ toS v ord' = parse pOrder ("failed to parse order (" ++ toS v ++ ")") $ toS v
pRequestRange :: (ByteString, NonnegRange) -> Either ParseError (Path, NonnegRange) pRequestRange :: (ByteString, NonnegRange) -> Either ApiRequestError (Path, NonnegRange)
pRequestRange (k, v) = (,) <$> path <*> pure v pRequestRange (k, v) = mapError $ (,) <$> path <*> pure v
where where
treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k treePath = parse pTreePath ("failed to parser tree path (" ++ toS k ++ ")") $ toS k
path = fst <$> treePath path = fst <$> treePath
@@ -152,3 +154,13 @@ pOrderTerm =
return $ OrderTerm c d nls return $ OrderTerm c d nls
) )
<|> OrderTerm <$> pField <*> pure Nothing <*> pure Nothing <|> 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)
src/PostgREST/Types.hs
+29 -1
View File
@@ -6,6 +6,21 @@ import qualified Data.ByteString.Lazy as BL
import Data.Tree import Data.Tree
import qualified Data.Vector as V import qualified Data.Vector as V
import PostgREST.RangeQuery (NonnegRange) 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 { data DbStructure = DbStructure {
dbTables :: [Table] dbTables :: [Table]
@@ -134,7 +149,6 @@ type ReadRequest = Tree ReadNode
type MutateRequest = MutateQuery type MutateRequest = MutateQuery
data DbRequest = DbRead ReadRequest | DbMutate MutateRequest data DbRequest = DbRead ReadRequest | DbMutate MutateRequest
instance ToJSON Column where instance ToJSON Column where
toJSON c = object [ toJSON c = object [
"schema" .= tableSchema t "schema" .= tableSchema t
@@ -172,3 +186,17 @@ instance Eq Table where
instance Eq Column where instance Eq Column where
Column{colTable=t1,colName=n1} == Column{colTable=t2,colName=n2} = t1 == t2 && n1 == n2 Column{colTable=t1,colName=n1} == Column{colTable=t2,colName=n2} = t1 == t2 && n1 == n2
_ == _ = False _ == _ = 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
test/Feature/QuerySpec.hs
+7 -1
View File
@@ -119,7 +119,7 @@ spec = do
it "matches filtering nested items 2" $ it "matches filtering nested items 2" $
get "/clients?select=id,projects{id,tasks2{id,name}}&projects.tasks.name=like.Design*" 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 { matchStatus = 400
, matchHeaders = [matchContentTypeJson] , matchHeaders = [matchContentTypeJson]
} }
@@ -600,6 +600,12 @@ spec = do
[json| [{"escapeId":1},{"escapeId":3},{"escapeId":5}] |] [json| [{"escapeId":1},{"escapeId":3},{"escapeId":5}] |]
{ matchHeaders = [matchContentTypeJson] } { 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" $ it "will embed a collection" $
get "/Escap3e;?select=ghostBusters{*}" `shouldRespondWith` get "/Escap3e;?select=ghostBusters{*}" `shouldRespondWith`
[json| [{"ghostBusters":[{"escapeId":1}]},{"ghostBusters":[]},{"ghostBusters":[{"escapeId":3}]},{"ghostBusters":[]},{"ghostBusters":[{"escapeId":5}]}] |] [json| [{"ghostBusters":[{"escapeId":1}]},{"ghostBusters":[]},{"ghostBusters":[{"escapeId":3}]},{"ghostBusters":[]},{"ghostBusters":[{"escapeId":5}]}] |]