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

Merge pull request #745 from diogob/moves_request_error_handling_to_user_api_request

Browse Source 
Moves request error handling to user api request
This commit is contained in:
Joe Nelson
2016-11-30 09:17:56 -08:00
committed by GitHub
parent ae40641963 6c275fcec2
commit 0f66e99f78
5 changed files with 126 additions and 149 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/PostgREST/ApiRequest.hs
+59 -64
View File
@@ -3,6 +3,7 @@ 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(..)
@@ -14,7 +15,6 @@ module PostgREST.ApiRequest ( ApiRequest(..)
) where ) where
import Protolude import Protolude
import qualified Data.Aeson as JSON import qualified Data.Aeson as JSON
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import qualified Data.ByteString.Internal as BS (c2w) import qualified Data.ByteString.Internal as BS (c2w)
@@ -36,9 +36,9 @@ 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, Payload(..), Schema,
UniformObjects(..)) PayloadJSON(..))
import Data.Ranged.Ranges (Range(..), singletonRange, rangeIntersection) import Data.Ranged.Ranges (Range(..), singletonRange, rangeIntersection, emptyRange)
type RequestBody = BL.ByteString type RequestBody = BL.ByteString
@@ -47,7 +47,6 @@ data Action = ActionCreate | ActionRead
| ActionUpdate | ActionDelete | ActionUpdate | ActionDelete
| ActionInfo | ActionInvoke | ActionInfo | ActionInvoke
| ActionInspect | ActionInspect
| ActionInappropriate
deriving Eq deriving Eq
-- | The target db object of a user action -- | The target db object of a user action
data Target = TargetIdent QualifiedIdentifier data Target = TargetIdent QualifiedIdentifier
@@ -62,6 +61,11 @@ data PreferRepresentation = Full | HeadersOnly | None deriving Eq
data ContentType = CTApplicationJSON | CTTextCSV | CTOpenAPI data ContentType = CTApplicationJSON | CTTextCSV | CTOpenAPI
| CTAny | CTOther BS.ByteString deriving Eq | CTAny | CTOther BS.ByteString deriving Eq
data ApiRequestError = ErrorActionInappropriate
| ErrorInvalidBody ByteString
| ErrorInvalidRange
deriving (Show, Eq)
-- | Convert from ContentType to a full HTTP Header -- | Convert from ContentType to a full HTTP Header
toHeader :: ContentType -> Header toHeader :: ContentType -> Header
toHeader ct = (hContentType, toMime ct <> "; charset=utf-8") toHeader ct = (hContentType, toMime ct <> "; charset=utf-8")
@@ -91,7 +95,7 @@ data ApiRequest = ApiRequest {
-- | Content types the client will accept, [CTAny] if no Accept header -- | Content types the client will accept, [CTAny] if no Accept header
, iAccepts :: [ContentType] , iAccepts :: [ContentType]
-- | Data sent by client and used for mutation actions -- | Data sent by client and used for mutation actions
, iPayload :: Maybe Payload , iPayload :: Maybe PayloadJSON
-- | If client wants created items echoed back -- | If client wants created items echoed back
, iPreferRepresentation :: PreferRepresentation , iPreferRepresentation :: PreferRepresentation
-- | If client wants first row as raw object -- | If client wants first row as raw object
@@ -113,59 +117,12 @@ 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 -> ApiRequest userApiRequest :: Schema -> Request -> RequestBody -> Either ApiRequestError ApiRequest
userApiRequest schema req reqBody = userApiRequest schema req reqBody
let action = | isTargetingProc && method /= "POST" = Left ErrorActionInappropriate
if isTargetingProc | topLevelRange == emptyRange = Left ErrorInvalidRange
then | shouldParsePayload && isLeft payload = either (Left . ErrorInvalidBody . toS) undefined payload
if method == "POST" | otherwise = Right ApiRequest {
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 iAction = action
, iTarget = target , iTarget = target
, iRange = ranges , iRange = ranges
@@ -186,11 +143,49 @@ userApiRequest schema req reqBody =
$ rawQueryString req $ rawQueryString req
, iJWT = tokenStr , iJWT = tokenStr
} }
where where
isTargetingProc = fromMaybe False $ (== "rpc") <$> listToMaybe path
payload =
case decodeContentType . fromMaybe "application/json" $ lookupHeader "content-type" of
CTApplicationJSON ->
either Left (\val -> case ensureUniform (pluralize val) of
Nothing -> Left "All object keys must match"
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 json) (CSV.decodeByName reqBody)
CTOther "application/x-www-form-urlencoded" ->
Right . PayloadJSON . V.singleton . M.fromList
. map (toS *** JSON.String . toS) . parseSimpleQuery
$ toS reqBody
ct ->
Left $ toS $ "Content-Type not acceptable: " <> toMime ct
topLevelRange = fromMaybe allRange $ M.lookup "limit" ranges
action = case method of
"GET" -> if target == TargetRoot
then ActionInspect
else ActionRead
"POST" -> if isTargetingProc
then ActionInvoke
else ActionCreate
"PATCH" -> ActionUpdate
"DELETE" -> ActionDelete
"OPTIONS" -> ActionInfo
_ -> ActionInspect
target = case path of
[] -> TargetRoot
[table] -> TargetIdent
$ QualifiedIdentifier schema table
["rpc", proc] -> TargetProc
$ QualifiedIdentifier schema proc
other -> TargetUnknown other
shouldParsePayload = action `elem` [ActionCreate, ActionUpdate, ActionInvoke]
relevantPayload = if shouldParsePayload
then rightToMaybe payload
else Nothing
path = pathInfo req path = pathInfo req
method = requestMethod req method = requestMethod req
isTargetingProc = fromMaybe False $ (== "rpc") <$> listToMaybe path
hdrs = requestHeaders req hdrs = requestHeaders req
qParams = [(toS k, v)|(k,v) <- queryString req] qParams = [(toS k, v)|(k,v) <- queryString req]
lookupHeader = flip lookup hdrs lookupHeader = flip lookup hdrs
@@ -288,8 +283,8 @@ pluralize (JSON.Array arr) = arr
pluralize _ = V.empty pluralize _ = V.empty
-- | Test that Array contains only Objects having the same keys -- | Test that Array contains only Objects having the same keys
-- and if so mark it as UniformObjects -- and if so mark it as PayloadJSON
ensureUniform :: JSON.Array -> Maybe UniformObjects ensureUniform :: JSON.Array -> Maybe PayloadJSON
ensureUniform arr = ensureUniform arr =
let objs :: V.Vector JSON.Object let objs :: V.Vector JSON.Object
objs = foldr -- filter non-objects, map to raw objects objs = foldr -- filter non-objects, map to raw objects
@@ -302,5 +297,5 @@ ensureUniform arr =
areKeysUniform = all (==canonicalKeys) keysPerObj in areKeysUniform = all (==canonicalKeys) keysPerObj in
if (V.length objs == V.length arr) && areKeysUniform if (V.length objs == V.length arr) && areKeysUniform
then Just (UniformObjects objs) then Just (PayloadJSON objs)
else Nothing else Nothing
src/PostgREST/App.hs
+20 -34
View File
@@ -11,7 +11,6 @@ import qualified Data.ByteString.Char8 as BS
import Data.IORef (IORef, readIORef) import Data.IORef (IORef, readIORef)
import Data.List (delete, lookup) import Data.List (delete, lookup)
import Data.Maybe (fromJust) import Data.Maybe (fromJust)
import Data.Ranged.Ranges (emptyRange)
import Data.Text (replace, strip, isInfixOf, dropWhile, drop, intercalate) import Data.Text (replace, strip, isInfixOf, dropWhile, drop, intercalate)
import Data.Time.Clock.POSIX (POSIXTime) import Data.Time.Clock.POSIX (POSIXTime)
import Data.Tree import Data.Tree
@@ -50,7 +49,7 @@ import PostgREST.ApiRequest ( ApiRequest(..), ContentType(..)
import PostgREST.Auth (jwtClaims, containsRole) import PostgREST.Auth (jwtClaims, containsRole)
import PostgREST.Config (AppConfig (..)) import PostgREST.Config (AppConfig (..))
import PostgREST.DbStructure import PostgREST.DbStructure
import PostgREST.Error (errResponse, pgErrResponse) import PostgREST.Error (errResponse, pgErrResponse, apiRequestErrResponse)
import PostgREST.Parsers import PostgREST.Parsers
import PostgREST.RangeQuery (NonnegRange, allRange, rangeOffset, restrictRange) import PostgREST.RangeQuery (NonnegRange, allRange, rangeOffset, restrictRange)
import PostgREST.Middleware import PostgREST.Middleware
@@ -81,17 +80,17 @@ postgrest conf refDbStructure pool getTime =
body <- strictRequestBody req body <- strictRequestBody req
dbStructure <- readIORef refDbStructure dbStructure <- readIORef refDbStructure
let schema = toS $ configSchema conf response <- case userApiRequest (configSchema conf) req body of
apiRequest = userApiRequest schema req body Left err -> return $ apiRequestErrResponse err
eClaims = jwtClaims Right apiRequest -> do
(secret <$> configJwtSecret conf) (iJWT apiRequest) time let jwtSecret = secret <$> configJwtSecret conf
eClaims = jwtClaims jwtSecret (iJWT apiRequest) time
authed = containsRole eClaims authed = containsRole eClaims
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.run handleReq HT.ReadCommitted txMode
resp <- either (pgErrResponse authed) id <$> P.use pool return $ either (pgErrResponse authed) identity response
(HT.run handleReq HT.ReadCommitted txMode) respond response
respond resp
transactionMode :: Action -> H.Mode transactionMode :: Action -> H.Mode
transactionMode ActionRead = HT.Read transactionMode ActionRead = HT.Read
@@ -108,7 +107,7 @@ app dbStructure conf apiRequest =
(ActionRead, TargetIdent qi, Nothing) -> (ActionRead, TargetIdent qi, Nothing) ->
case readSqlParts of case readSqlParts of
Left errorResponse -> return errorResponse Left errorResponse -> return errorResponse
Right (q, cq) -> respondToRange $ do Right (q, cq) -> do
let singular = iPreferSingular apiRequest let singular = iPreferSingular apiRequest
stm = createReadStatement q cq singular shouldCount (contentType == CTTextCSV) stm = createReadStatement q cq singular shouldCount (contentType == CTTextCSV)
row <- H.query () stm row <- H.query () stm
@@ -129,7 +128,7 @@ app dbStructure conf apiRequest =
) )
] (toS body) ] (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 case mutateSqlParts of
Left errorResponse -> return errorResponse Left errorResponse -> return errorResponse
Right (sq, mq) -> do Right (sq, mq) -> do
@@ -143,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 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 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 let (_, _, fs, body) = extractQueryResult row
headers = catMaybes [ headers = catMaybes [
if null fs if null fs
@@ -160,13 +159,13 @@ app dbStructure conf apiRequest =
if iPreferRepresentation apiRequest == Full if iPreferRepresentation apiRequest == Full
then toS body else "" then toS body else ""
(ActionUpdate, TargetIdent qi, Just payload@(PayloadJSON uniform)) -> (ActionUpdate, TargetIdent qi, Just payload) ->
case mutateSqlParts of case mutateSqlParts of
Left errorResponse -> return errorResponse Left errorResponse -> return errorResponse
Right (sq, mq) -> do Right (sq, mq) -> do
let singular = iPreferSingular apiRequest let singular = iPreferSingular apiRequest
stm = createWriteStatement qi sq mq singular (iPreferRepresentation apiRequest) [] (contentType == CTTextCSV) payload 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 let (_, queryTotal, _, body) = extractQueryResult row
when (singular && queryTotal > 1) $ when (singular && queryTotal > 1) $
HT.sql [P6.q| DO $$ HT.sql [P6.q| DO $$
@@ -188,10 +187,9 @@ app dbStructure conf apiRequest =
case mutateSqlParts of case mutateSqlParts of
Left errorResponse -> return errorResponse Left errorResponse -> return errorResponse
Right (sq, mq) -> do Right (sq, mq) -> do
let emptyUniform = UniformObjects V.empty let emptyPayload = PayloadJSON V.empty
fakeload = PayloadJSON emptyUniform stm = createWriteStatement qi sq mq False (iPreferRepresentation apiRequest) [] (contentType == CTTextCSV) emptyPayload
stm = createWriteStatement qi sq mq False (iPreferRepresentation apiRequest) [] (contentType == CTTextCSV) fakeload row <- H.query emptyPayload stm
row <- H.query emptyUniform stm
let (_, queryTotal, _, body) = extractQueryResult row let (_, queryTotal, _, body) = extractQueryResult row
r = contentRangeH 1 0 $ r = contentRangeH 1 0 $
toInteger <$> if shouldCount then Just queryTotal else Nothing toInteger <$> if shouldCount then Just queryTotal else Nothing
@@ -209,10 +207,10 @@ app dbStructure conf apiRequest =
let acceptH = (hAllow, if tableInsertable table then "GET,POST,PATCH,DELETE" else "GET") in let acceptH = (hAllow, if tableInsertable table then "GET,POST,PATCH,DELETE" else "GET") in
return $ responseLBS status200 [allOrigins, acceptH] "" return $ responseLBS status200 [allOrigins, acceptH] ""
(ActionInvoke, TargetProc qi, Just (PayloadJSON (UniformObjects payload))) -> (ActionInvoke, TargetProc qi, Just (PayloadJSON payload)) ->
case readSqlParts of case readSqlParts of
Left errorResponse -> return errorResponse Left errorResponse -> return errorResponse
Right (q, cq) -> respondToRange $ do Right (q, cq) -> do
let p = V.head payload let p = V.head payload
singular = iPreferSingular apiRequest singular = iPreferSingular apiRequest
paramsAsSingleObject = iPreferSingleObjectParameter apiRequest paramsAsSingleObject = iPreferSingleObjectParameter apiRequest
@@ -233,10 +231,6 @@ app dbStructure conf apiRequest =
body <- encodeApi . toTableInfo <$> H.query schema accessibleTables body <- encodeApi . toTableInfo <$> H.query schema accessibleTables
return $ responseLBS status200 [toHeader CTOpenAPI] $ toS body return $ responseLBS status200 [toHeader CTOpenAPI] $ toS body
(_, _, Just (PayloadParseError e)) ->
return $ errResponse status400 $
toS (formatGeneralError "Cannot parse request payload" (toS e))
_ -> return notFound _ -> return notFound
where where
@@ -273,16 +267,9 @@ app dbStructure conf apiRequest =
countQuery = requestToCountQuery schema <$> readDbRequest countQuery = requestToCountQuery schema <$> readDbRequest
readSqlParts = (,) <$> selectQuery <*> countQuery readSqlParts = (,) <$> selectQuery <*> countQuery
mutateSqlParts = (,) <$> selectQuery <*> mutateQuery mutateSqlParts = (,) <$> selectQuery <*> mutateQuery
respondToRange response =
if topLevelRange == emptyRange
then return $ errResponse status416 "HTTP Range error"
else response
responseContentTypeOrError :: [ContentType] -> Action -> Either Response ContentType responseContentTypeOrError :: [ContentType] -> Action -> Either Response ContentType
responseContentTypeOrError accepts action = responseContentTypeOrError accepts action = serves contentTypesForRequest accepts
case action of
ActionInappropriate -> Left $ errResponse status405 "Unsupported HTTP verb"
_ -> serves contentTypesForRequest accepts
where where
contentTypesForRequest = contentTypesForRequest =
case action of case action of
@@ -293,7 +280,6 @@ responseContentTypeOrError accepts action =
ActionInvoke -> [CTApplicationJSON] ActionInvoke -> [CTApplicationJSON]
ActionInspect -> [CTOpenAPI] ActionInspect -> [CTOpenAPI]
ActionInfo -> [CTTextCSV] ActionInfo -> [CTTextCSV]
ActionInappropriate -> []
serves sProduces cAccepts = serves sProduces cAccepts =
case mutuallyAgreeable sProduces cAccepts of case mutuallyAgreeable sProduces cAccepts of
Nothing -> do Nothing -> do
src/PostgREST/Error.hs
+9 -2
View File
@@ -2,7 +2,7 @@
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE TypeSynonymInstances #-}
module PostgREST.Error (pgErrResponse, errResponse, prettyUsageError) where module PostgREST.Error (apiRequestErrResponse, pgErrResponse, errResponse, prettyUsageError) where
import Protolude import Protolude
import Data.Aeson ((.=)) import Data.Aeson ((.=))
@@ -12,7 +12,14 @@ 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, 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 :: HT.Status -> Text -> Response
errResponse status message = responseLBS status errResponse status message = responseLBS status
src/PostgREST/QueryBuilder.hs
+10 -13
View File
@@ -83,12 +83,12 @@ decodeStandardMay =
HD.maybeRow standardRow HD.maybeRow standardRow
{-| JSON and CSV payloads from the client are given to us as {-| 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 and we turn this into an old fasioned JSON array
-} -}
encodeUniformObjs :: HE.Params UniformObjects encodeUniformObjs :: HE.Params PayloadJSON
encodeUniformObjs = 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 -> createReadStatement :: SqlQuery -> SqlQuery -> Bool -> Bool -> Bool ->
H.Query () ResultsWithCount H.Query () ResultsWithCount
@@ -111,11 +111,10 @@ createReadStatement selectQuery countQuery isSingle countTotal asCsv =
| otherwise = asJsonF | otherwise = asJsonF
createWriteStatement :: QualifiedIdentifier -> SqlQuery -> SqlQuery -> Bool -> createWriteStatement :: QualifiedIdentifier -> SqlQuery -> SqlQuery -> Bool ->
PreferRepresentation -> [Text] -> Bool -> Payload -> PreferRepresentation -> [Text] -> Bool -> PayloadJSON ->
H.Query UniformObjects (Maybe ResultsWithCount) H.Query PayloadJSON (Maybe ResultsWithCount)
createWriteStatement _ _ _ _ _ _ _ (PayloadParseError _) = undefined
createWriteStatement _ _ mutateQuery _ None createWriteStatement _ _ mutateQuery _ None
_ _ (PayloadJSON (UniformObjects _)) = _ _ (PayloadJSON _) =
unicodeStatement sql encodeUniformObjs decodeStandardMay True unicodeStatement sql encodeUniformObjs decodeStandardMay True
where where
sql = [qc| sql = [qc|
@@ -123,7 +122,7 @@ createWriteStatement _ _ mutateQuery _ None
SELECT '', 0, {noLocationF}, '' |] SELECT '', 0, {noLocationF}, '' |]
createWriteStatement qi _ mutateQuery isSingle HeadersOnly createWriteStatement qi _ mutateQuery isSingle HeadersOnly
pKeys _ (PayloadJSON (UniformObjects _)) = pKeys _ (PayloadJSON _) =
unicodeStatement sql encodeUniformObjs decodeStandardMay True unicodeStatement sql encodeUniformObjs decodeStandardMay True
where where
sql = [qc| sql = [qc|
@@ -138,7 +137,7 @@ createWriteStatement qi _ mutateQuery isSingle HeadersOnly
] ]
createWriteStatement qi selectQuery mutateQuery isSingle Full createWriteStatement qi selectQuery mutateQuery isSingle Full
pKeys asCsv (PayloadJSON (UniformObjects _)) = pKeys asCsv (PayloadJSON _) =
unicodeStatement sql encodeUniformObjs decodeStandardMay True unicodeStatement sql encodeUniformObjs decodeStandardMay True
where where
sql = [qc| sql = [qc|
@@ -322,8 +321,6 @@ requestToCountQuery schema (DbRead (Node (Select _ _ conditions _ _, (mainTbl, _
localConditions = filter fn conditions localConditions = filter fn conditions
requestToQuery :: Schema -> Bool -> DbRequest -> SqlQuery 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)) = requestToQuery schema isParent (DbRead (Node (Select colSelects tbls conditions ord range, (nodeName, maybeRelation, _)) forest)) =
query query
where where
@@ -384,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 --getQueryParts is not total but requestToQuery is called only after addJoinConditions which ensures the only
--posible relations are Child Parent Many --posible relations are Child Parent Many
getQueryParts _ _ = undefined --error "undefined getQueryParts" 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 let qi = QualifiedIdentifier schema mainTbl
cols = map pgFmtIdent $ fromMaybe [] (HM.keys <$> (rows V.!? 0)) cols = map pgFmtIdent $ fromMaybe [] (HM.keys <$> (rows V.!? 0))
colsString = intercalate ", " cols colsString = intercalate ", " cols
@@ -396,7 +393,7 @@ requestToQuery schema _ (DbMutate (Insert mainTbl (PayloadJSON (UniformObjects r
else ["SELECT", colsString, "FROM json_populate_recordset(null::" , fromQi qi, ", $1)"] in else ["SELECT", colsString, "FROM json_populate_recordset(null::" , fromQi qi, ", $1)"] in
insInto <> vals insInto <> vals
requestToQuery schema _ (DbMutate (Update mainTbl (PayloadJSON (UniformObjects rows)) conditions)) = requestToQuery schema _ (DbMutate (Update mainTbl (PayloadJSON rows) conditions)) =
case rows V.!? 0 of case rows V.!? 0 of
Just obj -> Just obj ->
let assignments = map let assignments = map
src/PostgREST/Types.hs
+5 -13
View File
@@ -2,7 +2,6 @@ module PostgREST.Types where
import Protolude import Protolude
import qualified GHC.Show import qualified GHC.Show
import Data.Aeson import Data.Aeson
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL 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
@@ -102,18 +101,11 @@ data Relation = Relation {
-- | An array of JSON objects that has been verified to have -- | An array of JSON objects that has been verified to have
-- the same keys in every object -- the same keys in every object
newtype UniformObjects = UniformObjects (V.Vector Object) newtype PayloadJSON = PayloadJSON (V.Vector Object)
deriving (Show, Eq) deriving (Show, Eq)
unUniformObjects :: UniformObjects -> V.Vector Object unPayloadJSON :: PayloadJSON -> V.Vector Object
unUniformObjects (UniformObjects objs) = objs unPayloadJSON (PayloadJSON 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 BS.ByteString
deriving (Show, Eq)
data Proxy = Proxy { data Proxy = Proxy {
proxyScheme :: Text proxyScheme :: Text
@@ -133,9 +125,9 @@ type NodeName = Text
type SelectItem = (Field, Maybe Cast, Maybe Alias) type SelectItem = (Field, Maybe Cast, Maybe Alias)
type Path = [Text] type Path = [Text]
data ReadQuery = Select { select::[SelectItem], from::[TableName], flt_::[Filter], order::Maybe [OrderTerm], range_::NonnegRange } deriving (Show, Eq) 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] } | 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) data Filter = Filter {field::Field, operator::Operator, value::FValue} deriving (Show, Eq)
type ReadNode = (ReadQuery, (NodeName, Maybe Relation, Maybe Alias)) type ReadNode = (ReadQuery, (NodeName, Maybe Relation, Maybe Alias))
type ReadRequest = Tree ReadNode type ReadRequest = Tree ReadNode