From 47c4fbc8ef06452c2caa1f563cec796f9e3b308c Mon Sep 17 00:00:00 2001 From: Diogo Biazus Date: Sun, 27 Nov 2016 23:54:23 -0500 Subject: [PATCH 01/10] Introduce the type ApiRequestError and make userApiRequest return an Either ApiRequestError ApiRequest --- src/PostgREST/ApiRequest.hs | 155 +++++++++++++++++++----------------- src/PostgREST/App.hs | 27 ++++--- src/PostgREST/Types.hs | 3 +- 3 files changed, 98 insertions(+), 87 deletions(-) diff --git a/src/PostgREST/ApiRequest.hs b/src/PostgREST/ApiRequest.hs index 30fef3380..73043cb70 100644 --- a/src/PostgREST/ApiRequest.hs +++ b/src/PostgREST/ApiRequest.hs @@ -3,6 +3,7 @@ Module : PostgREST.ApiRequest Description : PostgREST functions to translate HTTP request to a domain type called ApiRequest. -} module PostgREST.ApiRequest ( ApiRequest(..) + , ApiRequestError(..) , ContentType(..) , Action(..) , Target(..) @@ -62,6 +63,8 @@ data PreferRepresentation = Full | HeadersOnly | None deriving Eq data ContentType = CTApplicationJSON | CTTextCSV | CTOpenAPI | CTAny | CTOther BS.ByteString deriving Eq +data ApiRequestError = ErrorActionInappropriate | ErrorInvalidBody ByteString deriving (Show, Eq) + -- | Convert from ContentType to a full HTTP Header toHeader :: ContentType -> Header toHeader ct = (hContentType, toMime ct <> "; charset=utf-8") @@ -113,84 +116,86 @@ data ApiRequest = ApiRequest { } -- | Examines HTTP request and translates it into user intent. -userApiRequest :: Schema -> Request -> RequestBody -> ApiRequest -userApiRequest schema req reqBody = - let action = - if isTargetingProc - then - if method == "POST" - then ActionInvoke - else ActionInappropriate - else - case method of - "GET" -> if target == TargetRoot - then ActionInspect - else ActionRead - "POST" -> ActionCreate - "PATCH" -> ActionUpdate - "DELETE" -> ActionDelete - "OPTIONS" -> ActionInfo - _ -> ActionInappropriate - target = case path of - [] -> TargetRoot - [table] -> TargetIdent - $ QualifiedIdentifier schema table - ["rpc", proc] -> TargetProc - $ QualifiedIdentifier schema proc - other -> TargetUnknown other - payload = case decodeContentType - . fromMaybe "application/json" - $ lookupHeader "content-type" of - CTApplicationJSON -> - either (PayloadParseError . toS) - (\val -> case ensureUniform (pluralize val) of - Nothing -> PayloadParseError "All object keys must match" - Just json -> PayloadJSON json) - (JSON.eitherDecode reqBody) - CTTextCSV -> - either (PayloadParseError . toS) - (\val -> case ensureUniform (csvToJson val) of - Nothing -> PayloadParseError "All lines must have same number of fields" - Just json -> PayloadJSON json) - (CSV.decodeByName reqBody) - CTOther "application/x-www-form-urlencoded" -> - PayloadJSON . UniformObjects . V.singleton . M.fromList - . map (toS *** JSON.String . toS) . parseSimpleQuery - $ toS reqBody - ct -> - PayloadParseError $ "Content-Type not acceptable: " <> toMime ct - relevantPayload = case action of - ActionCreate -> Just payload - ActionUpdate -> Just payload - ActionInvoke -> Just payload - _ -> Nothing in - - ApiRequest { - iAction = action - , iTarget = target - , iRange = ranges - , iAccepts = fromMaybe [CTAny] $ - map decodeContentType . parseHttpAccept <$> lookupHeader "accept" - , iPayload = relevantPayload - , iPreferRepresentation = representation - , iPreferSingular = singular - , iPreferSingleObjectParameter = singleObject - , iPreferCount = not singular && hasPrefer "count=exact" - , iFilters = [ (toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, k /= "select", not (endingIn ["order", "limit", "offset"] k) ] - , iSelect = toS $ fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qParams - , iOrder = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["order"] k ] - , iCanonicalQS = toS $ urlEncodeVars - . L.sortBy (comparing fst) - . map (join (***) toS) - . parseSimpleQuery - $ rawQueryString req - , iJWT = tokenStr - } - +userApiRequest :: Schema -> Request -> RequestBody -> Either ApiRequestError ApiRequest +userApiRequest schema req reqBody + | isTargetingProc && method /= "POST" = Left ErrorActionInappropriate + | isError = Left $ ErrorInvalidBody payloadError + | otherwise = Right ApiRequest { + iAction = action + , iTarget = target + , iRange = ranges + , iAccepts = fromMaybe [CTAny] $ + map decodeContentType . parseHttpAccept <$> lookupHeader "accept" + , iPayload = relevantPayload + , iPreferRepresentation = representation + , iPreferSingular = singular + , iPreferSingleObjectParameter = singleObject + , iPreferCount = not singular && hasPrefer "count=exact" + , iFilters = [ (toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, k /= "select", not (endingIn ["order", "limit", "offset"] k) ] + , iSelect = toS $ fromMaybe "*" $ fromMaybe (Just "*") $ lookup "select" qParams + , iOrder = [(toS k, toS $ fromJust v) | (k,v) <- qParams, isJust v, endingIn ["order"] k ] + , iCanonicalQS = toS $ urlEncodeVars + . L.sortBy (comparing fst) + . map (join (***) toS) + . parseSimpleQuery + $ rawQueryString req + , iJWT = tokenStr + } where + isTargetingProc = fromMaybe False $ (== "rpc") <$> listToMaybe path + payloadError = case payload of + PayloadParseError err -> err + _ -> "" + isError = case relevantPayload of + Just (PayloadParseError _) -> True + _ -> False + payload = + case decodeContentType . fromMaybe "application/json" $ lookupHeader "content-type" of + CTApplicationJSON -> + either (PayloadParseError . toS) + (\val -> case ensureUniform (pluralize val) of + Nothing -> PayloadParseError "All object keys must match" + Just json -> PayloadJSON json) + (JSON.eitherDecode reqBody) + CTTextCSV -> + either (PayloadParseError . toS) + (\val -> case ensureUniform (csvToJson val) of + Nothing -> PayloadParseError "All lines must have same number of fields" + Just json -> PayloadJSON json) + (CSV.decodeByName reqBody) + CTOther "application/x-www-form-urlencoded" -> + PayloadJSON . UniformObjects . V.singleton . M.fromList + . map (toS *** JSON.String . toS) . parseSimpleQuery + $ toS reqBody + ct -> + PayloadParseError $ "Content-Type not acceptable: " <> toMime ct + action = + if isTargetingProc + then ActionInvoke + else + case method of + "GET" -> if target == TargetRoot + then ActionInspect + else ActionRead + "POST" -> ActionCreate + "PATCH" -> ActionUpdate + "DELETE" -> ActionDelete + "OPTIONS" -> ActionInfo + _ -> ActionInappropriate + target = case path of + [] -> TargetRoot + [table] -> TargetIdent + $ QualifiedIdentifier schema table + ["rpc", proc] -> TargetProc + $ QualifiedIdentifier schema proc + other -> TargetUnknown other + relevantPayload = case action of + ActionCreate -> Just payload + ActionUpdate -> Just payload + ActionInvoke -> Just payload + _ -> Nothing path = pathInfo req method = requestMethod req - isTargetingProc = fromMaybe False $ (== "rpc") <$> listToMaybe path hdrs = requestHeaders req qParams = [(toS k, v)|(k,v) <- queryString req] lookupHeader = flip lookup hdrs diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 3f0ba8d8b..a2a89dab3 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -40,6 +40,7 @@ import qualified Hasql.Transaction as H import qualified Data.HashMap.Strict as M import PostgREST.ApiRequest ( ApiRequest(..), ContentType(..) + , ApiRequestError(..) , Action(..), Target(..) , PreferRepresentation (..) , mutuallyAgreeable @@ -81,17 +82,23 @@ postgrest conf refDbStructure pool getTime = body <- strictRequestBody req dbStructure <- readIORef refDbStructure - let schema = toS $ configSchema conf - apiRequest = userApiRequest schema req body - eClaims = jwtClaims - (secret <$> configJwtSecret conf) (iJWT apiRequest) time - authed = containsRole eClaims - handleReq = runWithClaims conf eClaims (app dbStructure conf) apiRequest - txMode = transactionMode $ iAction apiRequest + case userApiRequest (configSchema conf) req body of + Left err -> respond $ respondToError err + Right apiRequest -> do + let eClaims = jwtClaims + (secret <$> configJwtSecret conf) (iJWT apiRequest) time + authed = containsRole eClaims + handleReq = runWithClaims conf eClaims (app dbStructure conf) apiRequest + txMode = transactionMode $ iAction apiRequest - resp <- either (pgErrResponse authed) id <$> P.use pool - (HT.run handleReq HT.ReadCommitted txMode) - respond resp + resp <- either (pgErrResponse authed) id <$> P.use pool + (HT.run handleReq HT.ReadCommitted txMode) + respond resp + where + respondToError error = + case error of + ErrorActionInappropriate -> errResponse status405 "Bad Request" + ErrorInvalidBody errorMessage -> errResponse status400 $ toS errorMessage transactionMode :: Action -> H.Mode transactionMode ActionRead = HT.Read diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs index 52a592077..8348d50a1 100644 --- a/src/PostgREST/Types.hs +++ b/src/PostgREST/Types.hs @@ -2,7 +2,6 @@ module PostgREST.Types where import Protolude import qualified GHC.Show import Data.Aeson -import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL import Data.Tree import qualified Data.Vector as V @@ -112,7 +111,7 @@ unUniformObjects (UniformObjects objs) = objs -- have a special payload just for CSV, but until -- then CSV is converted to a JSON array. data Payload = PayloadJSON UniformObjects - | PayloadParseError BS.ByteString + | PayloadParseError ByteString deriving (Show, Eq) data Proxy = Proxy { From b8ddc302524b8ae86cba5965e01e7d9b47c71c7e Mon Sep 17 00:00:00 2001 From: Diogo Biazus Date: Sun, 27 Nov 2016 23:54:37 -0500 Subject: [PATCH 02/10] Remove ActionInappropriate constructor from type Action since now we validate the request before building an ApiRequest. --- src/PostgREST/ApiRequest.hs | 3 +-- src/PostgREST/App.hs | 10 +++------- 2 files changed, 4 insertions(+), 9 deletions(-) diff --git a/src/PostgREST/ApiRequest.hs b/src/PostgREST/ApiRequest.hs index 73043cb70..cd14d332d 100644 --- a/src/PostgREST/ApiRequest.hs +++ b/src/PostgREST/ApiRequest.hs @@ -48,7 +48,6 @@ data Action = ActionCreate | ActionRead | ActionUpdate | ActionDelete | ActionInfo | ActionInvoke | ActionInspect - | ActionInappropriate deriving Eq -- | The target db object of a user action data Target = TargetIdent QualifiedIdentifier @@ -181,7 +180,7 @@ userApiRequest schema req reqBody "PATCH" -> ActionUpdate "DELETE" -> ActionDelete "OPTIONS" -> ActionInfo - _ -> ActionInappropriate + _ -> ActionInspect target = case path of [] -> TargetRoot [table] -> TargetIdent diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index a2a89dab3..345d97f9a 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -95,8 +95,8 @@ postgrest conf refDbStructure pool getTime = (HT.run handleReq HT.ReadCommitted txMode) respond resp where - respondToError error = - case error of + respondToError err = + case err of ErrorActionInappropriate -> errResponse status405 "Bad Request" ErrorInvalidBody errorMessage -> errResponse status400 $ toS errorMessage @@ -286,10 +286,7 @@ app dbStructure conf apiRequest = else response responseContentTypeOrError :: [ContentType] -> Action -> Either Response ContentType -responseContentTypeOrError accepts action = - case action of - ActionInappropriate -> Left $ errResponse status405 "Unsupported HTTP verb" - _ -> serves contentTypesForRequest accepts +responseContentTypeOrError accepts action = serves contentTypesForRequest accepts where contentTypesForRequest = case action of @@ -300,7 +297,6 @@ responseContentTypeOrError accepts action = ActionInvoke -> [CTApplicationJSON] ActionInspect -> [CTOpenAPI] ActionInfo -> [CTTextCSV] - ActionInappropriate -> [] serves sProduces cAccepts = case mutuallyAgreeable sProduces cAccepts of Nothing -> do From 6a02d9efd5ef658fda1fb788f10ece695f860c0d Mon Sep 17 00:00:00 2001 From: Diogo Biazus Date: Sun, 27 Nov 2016 23:54:48 -0500 Subject: [PATCH 03/10] Remove PayloadParseError matcher from main app case since now we validate the request before building an ApiRequest. --- src/PostgREST/App.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 345d97f9a..4cc1010c5 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -240,10 +240,6 @@ app dbStructure conf apiRequest = body <- encodeApi . toTableInfo <$> H.query schema accessibleTables return $ responseLBS status200 [toHeader CTOpenAPI] $ toS body - (_, _, Just (PayloadParseError e)) -> - return $ errResponse status400 $ - toS (formatGeneralError "Cannot parse request payload" (toS e)) - _ -> return notFound where From fec769c80e860869373a2b376842759cea38132e Mon Sep 17 00:00:00 2001 From: Diogo Biazus Date: Sun, 27 Nov 2016 23:54:52 -0500 Subject: [PATCH 04/10] Move range validation to userApiRequest. --- src/PostgREST/ApiRequest.hs | 8 +++++++- src/PostgREST/App.hs | 10 +++------- 2 files changed, 10 insertions(+), 8 deletions(-) diff --git a/src/PostgREST/ApiRequest.hs b/src/PostgREST/ApiRequest.hs index cd14d332d..a3c5e833f 100644 --- a/src/PostgREST/ApiRequest.hs +++ b/src/PostgREST/ApiRequest.hs @@ -15,6 +15,7 @@ module PostgREST.ApiRequest ( ApiRequest(..) ) where import Protolude +import Data.Ranged.Ranges (emptyRange) import qualified Data.Aeson as JSON import qualified Data.ByteString as BS @@ -62,7 +63,10 @@ data PreferRepresentation = Full | HeadersOnly | None deriving Eq data ContentType = CTApplicationJSON | CTTextCSV | CTOpenAPI | CTAny | CTOther BS.ByteString deriving Eq -data ApiRequestError = ErrorActionInappropriate | ErrorInvalidBody ByteString deriving (Show, Eq) +data ApiRequestError = ErrorActionInappropriate + | ErrorInvalidBody ByteString + | ErrorInvalidRange + deriving (Show, Eq) -- | Convert from ContentType to a full HTTP Header toHeader :: ContentType -> Header @@ -118,6 +122,7 @@ data ApiRequest = ApiRequest { userApiRequest :: Schema -> Request -> RequestBody -> Either ApiRequestError ApiRequest userApiRequest schema req reqBody | isTargetingProc && method /= "POST" = Left ErrorActionInappropriate + | topLevelRange == emptyRange = Left $ ErrorInvalidRange | isError = Left $ ErrorInvalidBody payloadError | otherwise = Right ApiRequest { iAction = action @@ -168,6 +173,7 @@ userApiRequest schema req reqBody $ toS reqBody ct -> PayloadParseError $ "Content-Type not acceptable: " <> toMime ct + topLevelRange = fromMaybe allRange $ M.lookup "limit" ranges action = if isTargetingProc then ActionInvoke diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 4cc1010c5..6be81be51 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -11,7 +11,6 @@ import qualified Data.ByteString.Char8 as BS import Data.IORef (IORef, readIORef) import Data.List (delete, lookup) import Data.Maybe (fromJust) -import Data.Ranged.Ranges (emptyRange) import Data.Text (replace, strip, isInfixOf, dropWhile, drop, intercalate) import Data.Time.Clock.POSIX (POSIXTime) import Data.Tree @@ -99,6 +98,7 @@ postgrest conf refDbStructure pool getTime = case err of ErrorActionInappropriate -> errResponse status405 "Bad Request" ErrorInvalidBody errorMessage -> errResponse status400 $ toS errorMessage + ErrorInvalidRange -> errResponse status416 "HTTP Range error" transactionMode :: Action -> H.Mode transactionMode ActionRead = HT.Read @@ -115,7 +115,7 @@ app dbStructure conf apiRequest = (ActionRead, TargetIdent qi, Nothing) -> case readSqlParts of Left errorResponse -> return errorResponse - Right (q, cq) -> respondToRange $ do + Right (q, cq) -> do let singular = iPreferSingular apiRequest stm = createReadStatement q cq singular shouldCount (contentType == CTTextCSV) row <- H.query () stm @@ -219,7 +219,7 @@ app dbStructure conf apiRequest = (ActionInvoke, TargetProc qi, Just (PayloadJSON (UniformObjects payload))) -> case readSqlParts of Left errorResponse -> return errorResponse - Right (q, cq) -> respondToRange $ do + Right (q, cq) -> do let p = V.head payload singular = iPreferSingular apiRequest paramsAsSingleObject = iPreferSingleObjectParameter apiRequest @@ -276,10 +276,6 @@ app dbStructure conf apiRequest = countQuery = requestToCountQuery schema <$> readDbRequest readSqlParts = (,) <$> selectQuery <*> countQuery mutateSqlParts = (,) <$> selectQuery <*> mutateQuery - respondToRange response = - if topLevelRange == emptyRange - then return $ errResponse status416 "HTTP Range error" - else response responseContentTypeOrError :: [ContentType] -> Action -> Either Response ContentType responseContentTypeOrError accepts action = serves contentTypesForRequest accepts From 654ac6e62eef6fdaa01bf35765338ef161234e37 Mon Sep 17 00:00:00 2001 From: Diogo Biazus Date: Sun, 27 Nov 2016 23:54:58 -0500 Subject: [PATCH 05/10] Move function to conver ApiRequestError to a Http Response to the Error module. --- src/PostgREST/App.hs | 11 ++--------- src/PostgREST/Error.hs | 11 +++++++++-- 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 6be81be51..f26949deb 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -39,7 +39,6 @@ import qualified Hasql.Transaction as H import qualified Data.HashMap.Strict as M import PostgREST.ApiRequest ( ApiRequest(..), ContentType(..) - , ApiRequestError(..) , Action(..), Target(..) , PreferRepresentation (..) , mutuallyAgreeable @@ -50,7 +49,7 @@ import PostgREST.ApiRequest ( ApiRequest(..), ContentType(..) import PostgREST.Auth (jwtClaims, containsRole) import PostgREST.Config (AppConfig (..)) import PostgREST.DbStructure -import PostgREST.Error (errResponse, pgErrResponse) +import PostgREST.Error (errResponse, pgErrResponse, apiRequestErrResponse) import PostgREST.Parsers import PostgREST.RangeQuery (NonnegRange, allRange, rangeOffset, restrictRange) import PostgREST.Middleware @@ -82,7 +81,7 @@ postgrest conf refDbStructure pool getTime = dbStructure <- readIORef refDbStructure case userApiRequest (configSchema conf) req body of - Left err -> respond $ respondToError err + Left err -> respond $ apiRequestErrResponse err Right apiRequest -> do let eClaims = jwtClaims (secret <$> configJwtSecret conf) (iJWT apiRequest) time @@ -93,12 +92,6 @@ postgrest conf refDbStructure pool getTime = resp <- either (pgErrResponse authed) id <$> P.use pool (HT.run handleReq HT.ReadCommitted txMode) respond resp - where - respondToError err = - case err of - ErrorActionInappropriate -> errResponse status405 "Bad Request" - ErrorInvalidBody errorMessage -> errResponse status400 $ toS errorMessage - ErrorInvalidRange -> errResponse status416 "HTTP Range error" transactionMode :: Action -> H.Mode transactionMode ActionRead = HT.Read diff --git a/src/PostgREST/Error.hs b/src/PostgREST/Error.hs index be4c2b1ac..75ae6d98d 100644 --- a/src/PostgREST/Error.hs +++ b/src/PostgREST/Error.hs @@ -2,7 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} -module PostgREST.Error (pgErrResponse, errResponse, prettyUsageError) where +module PostgREST.Error (apiRequestErrResponse, pgErrResponse, errResponse, prettyUsageError) where import Protolude import Data.Aeson ((.=)) @@ -12,7 +12,14 @@ 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, ContentType(..)) +import PostgREST.ApiRequest (toHeader, ContentType(..), ApiRequestError(..)) + +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" errResponse :: HT.Status -> Text -> Response errResponse status message = responseLBS status From 090a62a2c8f5cff39845cdf2b50fa9cf3beddfd3 Mon Sep 17 00:00:00 2001 From: Diogo Biazus Date: Sun, 27 Nov 2016 23:55:02 -0500 Subject: [PATCH 06/10] Removes error case from Payload type. Now we don't build a payload when the parsing fails. --- src/PostgREST/ApiRequest.hs | 45 +++++++++++++---------------------- src/PostgREST/QueryBuilder.hs | 3 --- src/PostgREST/Types.hs | 4 +--- 3 files changed, 18 insertions(+), 34 deletions(-) diff --git a/src/PostgREST/ApiRequest.hs b/src/PostgREST/ApiRequest.hs index a3c5e833f..4f1c5d657 100644 --- a/src/PostgREST/ApiRequest.hs +++ b/src/PostgREST/ApiRequest.hs @@ -15,8 +15,6 @@ module PostgREST.ApiRequest ( ApiRequest(..) ) where import Protolude -import Data.Ranged.Ranges (emptyRange) - import qualified Data.Aeson as JSON import qualified Data.ByteString as BS import qualified Data.ByteString.Internal as BS (c2w) @@ -40,7 +38,7 @@ import Data.Ranged.Boundaries import PostgREST.Types (QualifiedIdentifier (..), Schema, Payload(..), UniformObjects(..)) -import Data.Ranged.Ranges (Range(..), singletonRange, rangeIntersection) +import Data.Ranged.Ranges (Range(..), singletonRange, rangeIntersection, emptyRange) type RequestBody = BL.ByteString @@ -122,8 +120,8 @@ data ApiRequest = ApiRequest { userApiRequest :: Schema -> Request -> RequestBody -> Either ApiRequestError ApiRequest userApiRequest schema req reqBody | isTargetingProc && method /= "POST" = Left ErrorActionInappropriate - | topLevelRange == emptyRange = Left $ ErrorInvalidRange - | isError = Left $ ErrorInvalidBody payloadError + | topLevelRange == emptyRange = Left ErrorInvalidRange + | shouldParsePayload && isLeft payload = either (Left . ErrorInvalidBody . toS) undefined payload | otherwise = Right ApiRequest { iAction = action , iTarget = target @@ -147,32 +145,22 @@ userApiRequest schema req reqBody } where isTargetingProc = fromMaybe False $ (== "rpc") <$> listToMaybe path - payloadError = case payload of - PayloadParseError err -> err - _ -> "" - isError = case relevantPayload of - Just (PayloadParseError _) -> True - _ -> False payload = case decodeContentType . fromMaybe "application/json" $ lookupHeader "content-type" of CTApplicationJSON -> - either (PayloadParseError . toS) - (\val -> case ensureUniform (pluralize val) of - Nothing -> PayloadParseError "All object keys must match" - Just json -> PayloadJSON json) - (JSON.eitherDecode reqBody) + either Left (\val -> case ensureUniform (pluralize val) of + Nothing -> Left "All object keys must match" + Just json -> Right $ PayloadJSON json) (JSON.eitherDecode reqBody) CTTextCSV -> - either (PayloadParseError . toS) - (\val -> case ensureUniform (csvToJson val) of - Nothing -> PayloadParseError "All lines must have same number of fields" - Just json -> PayloadJSON json) - (CSV.decodeByName reqBody) + either Left (\val -> case ensureUniform (csvToJson val) of + Nothing -> Left "All lines must have same number of fields" + Just json -> Right $ PayloadJSON json) (CSV.decodeByName reqBody) CTOther "application/x-www-form-urlencoded" -> - PayloadJSON . UniformObjects . V.singleton . M.fromList + Right . PayloadJSON . UniformObjects . V.singleton . M.fromList . map (toS *** JSON.String . toS) . parseSimpleQuery $ toS reqBody ct -> - PayloadParseError $ "Content-Type not acceptable: " <> toMime ct + Left $ toS $ "Content-Type not acceptable: " <> toMime ct topLevelRange = fromMaybe allRange $ M.lookup "limit" ranges action = if isTargetingProc @@ -194,11 +182,12 @@ userApiRequest schema req reqBody ["rpc", proc] -> TargetProc $ QualifiedIdentifier schema proc other -> TargetUnknown other - relevantPayload = case action of - ActionCreate -> Just payload - ActionUpdate -> Just payload - ActionInvoke -> Just payload - _ -> Nothing + shouldParsePayload = action `elem` [ActionCreate, ActionUpdate, ActionInvoke] + relevantPayload = if shouldParsePayload + then case payload of + Right p -> Just p + Left _ -> Nothing + else Nothing path = pathInfo req method = requestMethod req hdrs = requestHeaders req diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs index 93a5410fd..99957e8b6 100644 --- a/src/PostgREST/QueryBuilder.hs +++ b/src/PostgREST/QueryBuilder.hs @@ -113,7 +113,6 @@ createReadStatement selectQuery countQuery isSingle countTotal asCsv = createWriteStatement :: QualifiedIdentifier -> SqlQuery -> SqlQuery -> Bool -> PreferRepresentation -> [Text] -> Bool -> Payload -> H.Query UniformObjects (Maybe ResultsWithCount) -createWriteStatement _ _ _ _ _ _ _ (PayloadParseError _) = undefined createWriteStatement _ _ mutateQuery _ None _ _ (PayloadJSON (UniformObjects _)) = unicodeStatement sql encodeUniformObjs decodeStandardMay True @@ -322,8 +321,6 @@ requestToCountQuery schema (DbRead (Node (Select _ _ conditions _ _, (mainTbl, _ localConditions = filter fn conditions requestToQuery :: Schema -> Bool -> DbRequest -> SqlQuery -requestToQuery _ _ (DbMutate (Insert _ (PayloadParseError _))) = undefined -requestToQuery _ _ (DbMutate (Update _ (PayloadParseError _) _)) = undefined requestToQuery schema isParent (DbRead (Node (Select colSelects tbls conditions ord range, (nodeName, maybeRelation, _)) forest)) = query where diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs index 8348d50a1..84b28171f 100644 --- a/src/PostgREST/Types.hs +++ b/src/PostgREST/Types.hs @@ -110,9 +110,7 @@ unUniformObjects (UniformObjects objs) = objs -- | When Hasql supports the COPY command then we can -- have a special payload just for CSV, but until -- then CSV is converted to a JSON array. -data Payload = PayloadJSON UniformObjects - | PayloadParseError ByteString - deriving (Show, Eq) +data Payload = PayloadJSON UniformObjects deriving (Show, Eq) data Proxy = Proxy { proxyScheme :: Text From 98ada3f9ee4751b60157f206a0f315ce3e895261 Mon Sep 17 00:00:00 2001 From: Diogo Biazus Date: Sun, 27 Nov 2016 23:55:07 -0500 Subject: [PATCH 07/10] Change nesting of if clause making code more symetrical --- src/PostgREST/ApiRequest.hs | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/src/PostgREST/ApiRequest.hs b/src/PostgREST/ApiRequest.hs index 4f1c5d657..877774bf6 100644 --- a/src/PostgREST/ApiRequest.hs +++ b/src/PostgREST/ApiRequest.hs @@ -162,15 +162,13 @@ userApiRequest schema req reqBody ct -> Left $ toS $ "Content-Type not acceptable: " <> toMime ct topLevelRange = fromMaybe allRange $ M.lookup "limit" ranges - action = - if isTargetingProc - then ActionInvoke - else - case method of + action = case method of "GET" -> if target == TargetRoot then ActionInspect else ActionRead - "POST" -> ActionCreate + "POST" -> if isTargetingProc + then ActionInvoke + else ActionCreate "PATCH" -> ActionUpdate "DELETE" -> ActionDelete "OPTIONS" -> ActionInfo From b158b4924eeaff328e3eb89a31247f7d230bc921 Mon Sep 17 00:00:00 2001 From: Diogo Biazus Date: Sun, 27 Nov 2016 23:55:14 -0500 Subject: [PATCH 08/10] Use rightToMaybe instead of case --- src/PostgREST/ApiRequest.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/PostgREST/ApiRequest.hs b/src/PostgREST/ApiRequest.hs index 877774bf6..1159c0013 100644 --- a/src/PostgREST/ApiRequest.hs +++ b/src/PostgREST/ApiRequest.hs @@ -182,9 +182,7 @@ userApiRequest schema req reqBody other -> TargetUnknown other shouldParsePayload = action `elem` [ActionCreate, ActionUpdate, ActionInvoke] relevantPayload = if shouldParsePayload - then case payload of - Right p -> Just p - Left _ -> Nothing + then rightToMaybe payload else Nothing path = pathInfo req method = requestMethod req From 16ac034aab0dbc02d4ad073bd57eb13a96a7a72f Mon Sep 17 00:00:00 2001 From: Diogo Biazus Date: Sun, 27 Nov 2016 23:55:19 -0500 Subject: [PATCH 09/10] Tidy up postgrest function body --- src/PostgREST/App.hs | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index f26949deb..124155501 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -80,18 +80,17 @@ postgrest conf refDbStructure pool getTime = body <- strictRequestBody req dbStructure <- readIORef refDbStructure - case userApiRequest (configSchema conf) req body of - Left err -> respond $ apiRequestErrResponse err + response <- case userApiRequest (configSchema conf) req body of + Left err -> return $ apiRequestErrResponse err Right apiRequest -> do - let eClaims = jwtClaims - (secret <$> configJwtSecret conf) (iJWT apiRequest) time + let jwtSecret = secret <$> configJwtSecret conf + eClaims = jwtClaims jwtSecret (iJWT apiRequest) time authed = containsRole eClaims handleReq = runWithClaims conf eClaims (app dbStructure conf) apiRequest txMode = transactionMode $ iAction apiRequest - - resp <- either (pgErrResponse authed) id <$> P.use pool - (HT.run handleReq HT.ReadCommitted txMode) - respond resp + response <- P.use pool $ HT.run handleReq HT.ReadCommitted txMode + return $ either (pgErrResponse authed) identity response + respond response transactionMode :: Action -> H.Mode transactionMode ActionRead = HT.Read From 6c275fcec22a75a3accac09b0917e6e1d1ce22b6 Mon Sep 17 00:00:00 2001 From: Diogo Biazus Date: Sun, 27 Nov 2016 23:55:26 -0500 Subject: [PATCH 10/10] Coalesce types UniformObjects and Payload into the new PayloadJSON --- src/PostgREST/ApiRequest.hs | 18 +++++++++--------- src/PostgREST/App.hs | 17 ++++++++--------- src/PostgREST/QueryBuilder.hs | 20 ++++++++++---------- src/PostgREST/Types.hs | 15 +++++---------- 4 files changed, 32 insertions(+), 38 deletions(-) diff --git a/src/PostgREST/ApiRequest.hs b/src/PostgREST/ApiRequest.hs index 1159c0013..26efe7f34 100644 --- a/src/PostgREST/ApiRequest.hs +++ b/src/PostgREST/ApiRequest.hs @@ -36,8 +36,8 @@ import Network.Wai.Parse (parseHttpAccept) import PostgREST.RangeQuery (NonnegRange, rangeRequested, restrictRange, rangeGeq, allRange, rangeLimit, rangeOffset) import Data.Ranged.Boundaries import PostgREST.Types (QualifiedIdentifier (..), - Schema, Payload(..), - UniformObjects(..)) + Schema, + PayloadJSON(..)) import Data.Ranged.Ranges (Range(..), singletonRange, rangeIntersection, emptyRange) type RequestBody = BL.ByteString @@ -95,7 +95,7 @@ data ApiRequest = ApiRequest { -- | Content types the client will accept, [CTAny] if no Accept header , iAccepts :: [ContentType] -- | Data sent by client and used for mutation actions - , iPayload :: Maybe Payload + , iPayload :: Maybe PayloadJSON -- | If client wants created items echoed back , iPreferRepresentation :: PreferRepresentation -- | If client wants first row as raw object @@ -150,13 +150,13 @@ userApiRequest schema req reqBody CTApplicationJSON -> either Left (\val -> case ensureUniform (pluralize val) of Nothing -> Left "All object keys must match" - Just json -> Right $ PayloadJSON json) (JSON.eitherDecode reqBody) + Just json -> Right json) (JSON.eitherDecode reqBody) CTTextCSV -> either Left (\val -> case ensureUniform (csvToJson val) of Nothing -> Left "All lines must have same number of fields" - Just json -> Right $ PayloadJSON json) (CSV.decodeByName reqBody) + Just json -> Right json) (CSV.decodeByName reqBody) CTOther "application/x-www-form-urlencoded" -> - Right . PayloadJSON . UniformObjects . V.singleton . M.fromList + Right . PayloadJSON . V.singleton . M.fromList . map (toS *** JSON.String . toS) . parseSimpleQuery $ toS reqBody ct -> @@ -283,8 +283,8 @@ pluralize (JSON.Array arr) = arr pluralize _ = V.empty -- | Test that Array contains only Objects having the same keys --- and if so mark it as UniformObjects -ensureUniform :: JSON.Array -> Maybe UniformObjects +-- and if so mark it as PayloadJSON +ensureUniform :: JSON.Array -> Maybe PayloadJSON ensureUniform arr = let objs :: V.Vector JSON.Object objs = foldr -- filter non-objects, map to raw objects @@ -297,5 +297,5 @@ ensureUniform arr = areKeysUniform = all (==canonicalKeys) keysPerObj in if (V.length objs == V.length arr) && areKeysUniform - then Just (UniformObjects objs) + then Just (PayloadJSON objs) else Nothing diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 124155501..db00892cb 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -128,7 +128,7 @@ app dbStructure conf apiRequest = ) ] (toS body) - (ActionCreate, TargetIdent qi@(QualifiedIdentifier _ table), Just payload@(PayloadJSON uniform@(UniformObjects rows))) -> + (ActionCreate, TargetIdent qi@(QualifiedIdentifier _ table), Just payload@(PayloadJSON rows)) -> case mutateSqlParts of Left errorResponse -> return errorResponse Right (sq, mq) -> do @@ -142,7 +142,7 @@ app dbStructure conf apiRequest = |] let pKeys = map pkName $ filter (filterPk schema table) allPrKeys -- would it be ok to move primary key detection in the query itself? let stm = createWriteStatement qi sq mq isSingle (iPreferRepresentation apiRequest) pKeys (contentType == CTTextCSV) payload - row <- H.query uniform stm + row <- H.query payload stm let (_, _, fs, body) = extractQueryResult row headers = catMaybes [ if null fs @@ -159,13 +159,13 @@ app dbStructure conf apiRequest = if iPreferRepresentation apiRequest == Full then toS body else "" - (ActionUpdate, TargetIdent qi, Just payload@(PayloadJSON uniform)) -> + (ActionUpdate, TargetIdent qi, Just payload) -> case mutateSqlParts of Left errorResponse -> return errorResponse Right (sq, mq) -> do let singular = iPreferSingular apiRequest stm = createWriteStatement qi sq mq singular (iPreferRepresentation apiRequest) [] (contentType == CTTextCSV) payload - row <- H.query uniform stm + row <- H.query payload stm let (_, queryTotal, _, body) = extractQueryResult row when (singular && queryTotal > 1) $ HT.sql [P6.q| DO $$ @@ -187,10 +187,9 @@ app dbStructure conf apiRequest = case mutateSqlParts of Left errorResponse -> return errorResponse Right (sq, mq) -> do - let emptyUniform = UniformObjects V.empty - fakeload = PayloadJSON emptyUniform - stm = createWriteStatement qi sq mq False (iPreferRepresentation apiRequest) [] (contentType == CTTextCSV) fakeload - row <- H.query emptyUniform stm + let emptyPayload = PayloadJSON V.empty + stm = createWriteStatement qi sq mq False (iPreferRepresentation apiRequest) [] (contentType == CTTextCSV) emptyPayload + row <- H.query emptyPayload stm let (_, queryTotal, _, body) = extractQueryResult row r = contentRangeH 1 0 $ toInteger <$> if shouldCount then Just queryTotal else Nothing @@ -208,7 +207,7 @@ app dbStructure conf apiRequest = let acceptH = (hAllow, if tableInsertable table then "GET,POST,PATCH,DELETE" else "GET") in return $ responseLBS status200 [allOrigins, acceptH] "" - (ActionInvoke, TargetProc qi, Just (PayloadJSON (UniformObjects payload))) -> + (ActionInvoke, TargetProc qi, Just (PayloadJSON payload)) -> case readSqlParts of Left errorResponse -> return errorResponse Right (q, cq) -> do diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs index 99957e8b6..03a077c82 100644 --- a/src/PostgREST/QueryBuilder.hs +++ b/src/PostgREST/QueryBuilder.hs @@ -83,12 +83,12 @@ decodeStandardMay = HD.maybeRow standardRow {-| JSON and CSV payloads from the client are given to us as - UniformObjects (objects who all have the same keys), + PayloadJSON (objects who all have the same keys), and we turn this into an old fasioned JSON array -} -encodeUniformObjs :: HE.Params UniformObjects +encodeUniformObjs :: HE.Params PayloadJSON encodeUniformObjs = - contramap (JSON.Array . V.map JSON.Object . unUniformObjects) (HE.value HE.json) + contramap (JSON.Array . V.map JSON.Object . unPayloadJSON) (HE.value HE.json) createReadStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool -> H.Query () ResultsWithCount @@ -111,10 +111,10 @@ createReadStatement selectQuery countQuery isSingle countTotal asCsv = | otherwise = asJsonF createWriteStatement :: QualifiedIdentifier -> SqlQuery -> SqlQuery -> Bool -> - PreferRepresentation -> [Text] -> Bool -> Payload -> - H.Query UniformObjects (Maybe ResultsWithCount) + PreferRepresentation -> [Text] -> Bool -> PayloadJSON -> + H.Query PayloadJSON (Maybe ResultsWithCount) createWriteStatement _ _ mutateQuery _ None - _ _ (PayloadJSON (UniformObjects _)) = + _ _ (PayloadJSON _) = unicodeStatement sql encodeUniformObjs decodeStandardMay True where sql = [qc| @@ -122,7 +122,7 @@ createWriteStatement _ _ mutateQuery _ None SELECT '', 0, {noLocationF}, '' |] createWriteStatement qi _ mutateQuery isSingle HeadersOnly - pKeys _ (PayloadJSON (UniformObjects _)) = + pKeys _ (PayloadJSON _) = unicodeStatement sql encodeUniformObjs decodeStandardMay True where sql = [qc| @@ -137,7 +137,7 @@ createWriteStatement qi _ mutateQuery isSingle HeadersOnly ] createWriteStatement qi selectQuery mutateQuery isSingle Full - pKeys asCsv (PayloadJSON (UniformObjects _)) = + pKeys asCsv (PayloadJSON _) = unicodeStatement sql encodeUniformObjs decodeStandardMay True where sql = [qc| @@ -381,7 +381,7 @@ requestToQuery schema isParent (DbRead (Node (Select colSelects tbls conditions --getQueryParts is not total but requestToQuery is called only after addJoinConditions which ensures the only --posible relations are Child Parent Many getQueryParts _ _ = undefined --error "undefined getQueryParts" -requestToQuery schema _ (DbMutate (Insert mainTbl (PayloadJSON (UniformObjects rows)))) = +requestToQuery schema _ (DbMutate (Insert mainTbl (PayloadJSON rows))) = let qi = QualifiedIdentifier schema mainTbl cols = map pgFmtIdent $ fromMaybe [] (HM.keys <$> (rows V.!? 0)) colsString = intercalate ", " cols @@ -393,7 +393,7 @@ requestToQuery schema _ (DbMutate (Insert mainTbl (PayloadJSON (UniformObjects r else ["SELECT", colsString, "FROM json_populate_recordset(null::" , fromQi qi, ", $1)"] in insInto <> vals -requestToQuery schema _ (DbMutate (Update mainTbl (PayloadJSON (UniformObjects rows)) conditions)) = +requestToQuery schema _ (DbMutate (Update mainTbl (PayloadJSON rows) conditions)) = case rows V.!? 0 of Just obj -> let assignments = map diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs index 84b28171f..5136ffc04 100644 --- a/src/PostgREST/Types.hs +++ b/src/PostgREST/Types.hs @@ -101,16 +101,11 @@ data Relation = Relation { -- | An array of JSON objects that has been verified to have -- the same keys in every object -newtype UniformObjects = UniformObjects (V.Vector Object) +newtype PayloadJSON = PayloadJSON (V.Vector Object) deriving (Show, Eq) -unUniformObjects :: UniformObjects -> V.Vector Object -unUniformObjects (UniformObjects objs) = objs - --- | When Hasql supports the COPY command then we can --- have a special payload just for CSV, but until --- then CSV is converted to a JSON array. -data Payload = PayloadJSON UniformObjects deriving (Show, Eq) +unPayloadJSON :: PayloadJSON -> V.Vector Object +unPayloadJSON (PayloadJSON objs) = objs data Proxy = Proxy { proxyScheme :: Text @@ -130,9 +125,9 @@ type NodeName = Text type SelectItem = (Field, Maybe Cast, Maybe Alias) type Path = [Text] data ReadQuery = Select { select::[SelectItem], from::[TableName], flt_::[Filter], order::Maybe [OrderTerm], range_::NonnegRange } deriving (Show, Eq) -data MutateQuery = Insert { in_::TableName, qPayload::Payload } +data MutateQuery = Insert { in_::TableName, qPayload::PayloadJSON } | Delete { in_::TableName, where_::[Filter] } - | Update { in_::TableName, qPayload::Payload, where_::[Filter] } deriving (Show, Eq) + | Update { in_::TableName, qPayload::PayloadJSON, where_::[Filter] } deriving (Show, Eq) data Filter = Filter {field::Field, operator::Operator, value::FValue} deriving (Show, Eq) type ReadNode = (ReadQuery, (NodeName, Maybe Relation, Maybe Alias)) type ReadRequest = Tree ReadNode