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

Merge pull request #383 from ruslantalpa/simplify

Browse Source 
Type refactoring (ApiRequest/DbRequest)
This commit is contained in:
Joe Nelson
2015-11-23 09:31:01 -08:00
parent 7f58600dbb 50745ad48b
commit 64da08b220
7 changed files with 75 additions and 71 deletions
Download Patch File Download Diff File Expand all files Collapse all files
postgrest.cabal
+3 -3
View File
@@ -72,7 +72,7 @@ executable postgrest
, PostgREST.DbStructure
, PostgREST.QueryBuilder
, PostgREST.RangeQuery
, PostgREST.RequestIntent
, PostgREST.ApiRequest
, PostgREST.Types
library
@@ -136,7 +136,7 @@ library
, PostgREST.DbStructure
, PostgREST.QueryBuilder
, PostgREST.RangeQuery
, PostgREST.RequestIntent
, PostgREST.ApiRequest
, PostgREST.Types
hs-source-dirs: src
@@ -167,7 +167,7 @@ Test-Suite spec
, PostgREST.DbStructure
, PostgREST.QueryBuilder
, PostgREST.RangeQuery
, PostgREST.RequestIntent
, PostgREST.ApiRequest
, PostgREST.Types
, Spec
, SpecHelper
src/PostgREST/RequestIntent.hs → src/PostgREST/ApiRequest.hs
+5 -5
View File
@@ -1,4 +1,4 @@
module PostgREST.RequestIntent where
module PostgREST.ApiRequest where
import qualified Data.Aeson as JSON
import qualified Data.ByteString as BS
@@ -46,7 +46,7 @@ instance Show ContentType where
sensible, it is up to a later stage of processing to determine
if it is an action we are able to perform.
-}
data Intent = Intent {
data ApiRequest = ApiRequest {
-- | Set to Nothing for unknown HTTP verbs
iAction :: Action
-- | Set to Nothing for malformed range
@@ -72,8 +72,8 @@ data Intent = Intent {
}
-- | Examines HTTP request and translates it into user intent.
userIntent :: Schema -> Request -> RequestBody -> Intent
userIntent schema req reqBody =
userApiRequest :: Schema -> Request -> RequestBody -> ApiRequest
userApiRequest schema req reqBody =
let action = case method of
"GET" -> ActionRead
"POST" -> if isTargetingProc
@@ -112,7 +112,7 @@ userIntent schema req reqBody =
ActionInvoke -> Just payload
_ -> Nothing in
Intent {
ApiRequest {
iAction = action
, iRange = if singular then Nothing else rangeRequested hdrs
, iTarget = target
src/PostgREST/App.hs
+39 -39
View File
@@ -12,8 +12,7 @@ import Control.Monad (join)
import Data.Bifunctor (first)
import qualified Data.ByteString.Lazy as BL
import Data.Functor.Identity
import qualified Data.HashMap.Strict as HM
import Data.List (find, sortBy, delete, transpose)
import Data.List (find, sortBy, delete)
import Data.Maybe (fromMaybe, fromJust, isNothing, mapMaybe)
import Data.Ord (comparing)
import Data.Ranged.Ranges (emptyRange, singletonRange)
@@ -43,9 +42,9 @@ import PostgREST.Config (AppConfig (..))
import PostgREST.Parsers
import PostgREST.DbStructure
import PostgREST.RangeQuery
import PostgREST.RequestIntent (Intent(..), ContentType(..)
import PostgREST.ApiRequest (ApiRequest(..), ContentType(..)
, Action(..), Target(..)
, userIntent)
, userApiRequest)
import PostgREST.Types
import PostgREST.Auth (tokenJWT)
import PostgREST.Error (errResponse)
@@ -73,19 +72,19 @@ app :: DbStructure -> AppConfig -> RequestBody -> Request -> H.Tx P.Postgres s R
app dbStructure conf reqBody req =
let
-- TODO: blow up for Left values (there is a middleware that checks the headers)
contentType = either (const ApplicationJSON) id (iAccepts intent)
contentType = either (const ApplicationJSON) id (iAccepts apiRequest)
contentTypeH = (hContentType, cs $ show contentType) in
case (iAction intent, iTarget intent, iPayload intent) of
case (iAction apiRequest, iTarget apiRequest, iPayload apiRequest) of
(ActionRead, TargetIdent qi, Nothing) ->
case selectQuery of
Left e -> return $ responseLBS status400 [jsonH] $ cs e
Right q -> do
let range = iRange intent
singular = iPreferSingular intent
let range = iRange apiRequest
singular = iPreferSingular apiRequest
stm = createReadStatement q range singular
(iPreferCount intent) (contentType == TextCSV)
(iPreferCount apiRequest) (contentType == TextCSV)
if range == Just emptyRange
then return $ errResponse status416 "HTTP Range error"
else do
@@ -120,7 +119,7 @@ app dbStructure conf reqBody req =
Right (sq,mq) -> do
let isSingle = (==1) $ V.length rows
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 sq mq isSingle (iPreferRepresentation intent) pKeys (contentType == TextCSV) payload
let stm = createWriteStatement sq mq isSingle (iPreferRepresentation apiRequest) pKeys (contentType == TextCSV) payload
row <- H.maybeEx stm
let (_, _, location, body) = extractQueryResult row
return $ responseLBS status201
@@ -128,21 +127,21 @@ app dbStructure conf reqBody req =
contentTypeH,
(hLocation, "/" <> cs table <> "?" <> cs (fromMaybe "" location))
]
$ if iPreferRepresentation intent then fromMaybe "[]" body else ""
$ if iPreferRepresentation apiRequest then fromMaybe "[]" body else ""
(ActionUpdate, TargetIdent _, Just payload@(PayloadJSON _)) ->
case queries of
Left e -> return $ responseLBS status400 [jsonH] $ cs e
Right (sq,mq) -> do
let stm = createWriteStatement sq mq False (iPreferRepresentation intent) [] (contentType == TextCSV) payload
let stm = createWriteStatement sq mq False (iPreferRepresentation apiRequest) [] (contentType == TextCSV) payload
row <- H.maybeEx stm
let (_, queryTotal, _, body) = extractQueryResult row
r = contentRangeH 0 (queryTotal-1) (Just queryTotal)
s = case () of _ | queryTotal == 0 -> status404
| iPreferRepresentation intent -> status200
| iPreferRepresentation apiRequest -> status200
| otherwise -> status204
return $ responseLBS s [contentTypeH, r]
$ if iPreferRepresentation intent then fromMaybe "[]" body else ""
$ if iPreferRepresentation apiRequest then fromMaybe "[]" body else ""
(ActionDelete, TargetIdent _, Nothing) ->
case queries of
@@ -204,9 +203,9 @@ app dbStructure conf reqBody req =
allPrKeys = dbPrimaryKeys dbStructure
allOrigins = ("Access-Control-Allow-Origin", "*") :: Header
schema = cs $ configSchema conf
intent = userIntent schema req reqBody
selectQuery = requestToQuery schema <$> buildSelectApiRequest (dbRelations dbStructure) intent
mutateQuery = requestToQuery schema <$> buildMutateApiRequest intent
apiRequest = userApiRequest schema req reqBody
selectQuery = requestToQuery schema <$> (DbRead <$> buildReadRequest (dbRelations dbStructure) apiRequest)
mutateQuery = requestToQuery schema <$> (DbMutate <$> buildMutateRequest apiRequest)
queries = (,) <$> selectQuery <*> mutateQuery
rangeStatus :: Int -> Int -> Maybe Int -> Status
@@ -247,19 +246,19 @@ formatGeneralError message details = cs $ encode $ object [
"message" .= message,
"details" .= details]
augumentRequestWithJoin :: Schema -> [Relation] -> ApiRequest -> Either Text ApiRequest
augumentRequestWithJoin :: Schema -> [Relation] -> ReadRequest -> Either Text ReadRequest
augumentRequestWithJoin schema allRels request =
(first formatRelationError . addRelations schema allRels Nothing) request
>>= addJoinConditions schema
buildSelectApiRequest :: [Relation] -> Intent -> Either Text ApiRequest
buildSelectApiRequest allRels intent =
augumentRequestWithJoin schema rels =<< first formatParserError (foldr addFilter <$> (addOrder <$> apiRequest <*> ord) <*> flts)
buildReadRequest :: [Relation] -> ApiRequest -> Either Text ReadRequest
buildReadRequest allRels apiRequest =
augumentRequestWithJoin schema rels =<< first formatParserError (foldr addFilter <$> (addOrder <$> readRequest <*> ord) <*> flts)
where
selStr = iSelect intent
orderS = iOrder intent
action = iAction intent
target = iTarget intent
selStr = iSelect apiRequest
orderS = iOrder apiRequest
action = iAction apiRequest
target = iTarget apiRequest
(schema, rootTableName) = fromJust $ -- Make it safe
case target of
(TargetIdent (QualifiedIdentifier s t) ) -> Just (s, t)
@@ -269,39 +268,39 @@ buildSelectApiRequest allRels intent =
then rootTableName
else sourceSubqueryName
filters = if action == ActionRead
then iFilters intent
else filter (( '.' `elem` ) . fst) $ iFilters intent -- there can be no filters on the root table whre we are doing insert/update
then iFilters apiRequest
else filter (( '.' `elem` ) . fst) $ iFilters apiRequest -- there can be no filters on the root table whre we are doing insert/update
rels = case action of
ActionCreate -> fakeSourceRelations ++ allRels
ActionUpdate -> fakeSourceRelations ++ allRels
_ -> allRels
where fakeSourceRelations = mapMaybe (toSourceRelation rootTableName) allRels -- see comment in toSourceRelation
apiRequest = parse (pRequestSelect rootName) ("failed to parse select parameter <<"++selStr++">>") selStr
readRequest = parse (pRequestSelect rootName) ("failed to parse select parameter <<"++selStr++">>") selStr
addOrder (Node (q,i) f) o = Node (q{order=o}, i) f
flts = mapM pRequestFilter filters
ord = traverse (parse pOrder ("failed to parse order parameter <<"++fromMaybe "" orderS++">>")) orderS
buildMutateApiRequest :: Intent -> Either Text ApiRequest
buildMutateApiRequest intent =
buildMutateRequest :: ApiRequest -> Either Text MutateRequest
buildMutateRequest apiRequest =
mutateApiRequest
where
action = iAction intent
target = iTarget intent
payload = fromJust $ iPayload intent
action = iAction apiRequest
target = iTarget apiRequest
payload = fromJust $ iPayload apiRequest
rootTableName = -- TODO: Make it safe
case target of
(TargetIdent (QualifiedIdentifier _ t) ) -> t
_ -> undefined
mutateApiRequest = case action of
ActionCreate -> Node <$> ((,) <$> (Insert rootTableName <$> pure payload) <*> pure (rootTableName, Nothing)) <*> pure []
ActionUpdate -> Node <$> ((,) <$> (Update rootTableName <$> pure payload <*> cond) <*> pure (rootTableName, Nothing)) <*> pure []
ActionDelete -> Node <$> ((,) <$> (Delete [rootTableName] <$> cond) <*> pure (rootTableName, Nothing)) <*> pure []
ActionCreate -> Insert rootTableName <$> pure payload
ActionUpdate -> Update rootTableName <$> pure payload <*> cond
ActionDelete -> Delete rootTableName <$> cond
_ -> Left "Unsupported HTTP verb"
mutateFilters = filter (not . ( '.' `elem` ) . fst) $ iFilters intent -- update/delete filters can be only on the root table
mutateFilters = filter (not . ( '.' `elem` ) . fst) $ iFilters apiRequest -- update/delete filters can be only on the root table
cond = first formatParserError $ map snd <$> mapM pRequestFilter mutateFilters
addFilter :: (Path, Filter) -> ApiRequest -> ApiRequest
addFilter ([], flt) (Node (q@(Select {where_=flts}), i) forest) = Node (q {where_=flt:flts}, i) forest
addFilter :: (Path, Filter) -> ReadRequest -> ReadRequest
addFilter ([], flt) (Node (q@(Select {flt_=flts}), i) forest) = Node (q {flt_=flt:flts}, i) forest
addFilter (path, flt) (Node rn forest) =
case targetNode of
Nothing -> Node rn forest -- the filter is silenty dropped in the Request does not contain the required path
@@ -352,6 +351,7 @@ createReadStatement selectQuery range isSingle countTable asCsv =
createWriteStatement :: SqlQuery -> SqlQuery -> Bool -> Bool ->
[Text] -> Bool -> Payload -> B.Stmt P.Postgres
createWriteStatement _ _ _ _ _ _ (PayloadParseError _) = undefined
createWriteStatement selectQuery mutateQuery isSingle echoRequested
pKeys asCsv (PayloadJSON (UniformObjects rows)) =
B.Stmt (
src/PostgREST/Middleware.hs
+1 -1
View File
@@ -18,7 +18,7 @@ import Network.Wai.Middleware.Cors (cors)
import Network.Wai.Middleware.Gzip (def, gzip)
import Network.Wai.Middleware.Static (only, staticPolicy)
import PostgREST.RequestIntent (pickContentType)
import PostgREST.ApiRequest (pickContentType)
import PostgREST.Auth (setRole, jwtClaims, claimsToSQL)
import PostgREST.Config (AppConfig (..), corsPolicy)
import PostgREST.Error (errResponse)
src/PostgREST/Parsers.hs
+2 -2
View File
@@ -12,12 +12,12 @@ import PostgREST.Types
import Text.ParserCombinators.Parsec hiding (many, (<|>))
import PostgREST.QueryBuilder (operators)
pRequestSelect :: Text -> Parser ApiRequest
pRequestSelect :: Text -> Parser ReadRequest
pRequestSelect rootNodeName = do
fieldTree <- pFieldForest
return $ foldr treeEntry (Node (Select [] [rootNodeName] [] Nothing, (rootNodeName, Nothing)) []) fieldTree
where
treeEntry :: Tree SelectItem -> ApiRequest -> ApiRequest
treeEntry :: Tree SelectItem -> ReadRequest -> ReadRequest
treeEntry (Node fld@((fn, _),_) fldForest) (Node (q, i) rForest) =
case fldForest of
[] -> Node (q {select=fld:select q}, i) rForest
src/PostgREST/QueryBuilder.hs
+17 -15
View File
@@ -58,7 +58,7 @@ instance Monoid PStmt where
mempty = B.Stmt "" empty True
type StatementT = PStmt -> PStmt
addRelations :: Schema -> [Relation] -> Maybe ApiRequest -> ApiRequest -> Either Text ApiRequest
addRelations :: Schema -> [Relation] -> Maybe ReadRequest -> ReadRequest -> Either Text ReadRequest
addRelations schema allRelations parentNode node@(Node n@(query, (table, _)) forest) =
case parentNode of
Nothing -> Node (query, (table, Nothing)) <$> updatedForest
@@ -67,14 +67,14 @@ addRelations schema allRelations parentNode node@(Node n@(query, (table, _)) for
rel = note ("no relation between " <> table <> " and " <> parentTable)
$ findRelation schema table parentTable
<|> findRelation schema parentTable table
addRel :: (Query, (NodeName, Maybe Relation)) -> Relation -> (Query, (NodeName, Maybe Relation))
addRel :: (ReadQuery, (NodeName, Maybe Relation)) -> Relation -> (ReadQuery, (NodeName, Maybe Relation))
addRel (q, (t, _)) r = (q, (t, Just r))
where
updatedForest = mapM (addRelations schema allRelations (Just node)) forest
findRelation s t1 t2 =
find (\r -> s == (tableSchema . relTable) r && t1 == (tableName . relTable) r && t2 == (tableName . relFTable) r) allRelations
addJoinConditions :: Schema -> ApiRequest -> Either Text ApiRequest
addJoinConditions :: Schema -> ReadRequest -> Either Text ReadRequest
addJoinConditions schema (Node (query, (n, r)) forest) =
case r of
Nothing -> Node (updatedQuery, (n,r)) <$> updatedForest -- this is the root node
@@ -96,7 +96,7 @@ addJoinConditions schema (Node (query, (n, r)) forest) =
getParents (_, (tbl, Just rel@(Relation{relType=Parent}))) = Just (tbl, rel)
getParents _ = Nothing
updatedForest = mapM (addJoinConditions schema) forest
addCond q con = q{where_=con ++ where_ q}
addCond q con = q{flt_=con ++ flt_ q}
asCsvF :: SqlFragment
asCsvF = asCsvHeaderF <> " || '\n' || " <> asCsvBodyF
@@ -189,8 +189,10 @@ pgFmtLit x =
then "E" <> slashed
else slashed
requestToQuery :: Schema -> ApiRequest -> SqlQuery
requestToQuery schema (Node (Select colSelects tbls conditions ord, (mainTbl, _)) forest) =
requestToQuery :: Schema -> DbRequest -> SqlQuery
requestToQuery _ (DbMutate (Insert _ (PayloadParseError _))) = undefined
requestToQuery _ (DbMutate (Update _ (PayloadParseError _) _)) = undefined
requestToQuery schema (DbRead (Node (Select colSelects tbls conditions ord, (mainTbl, _)) forest)) =
query
where
-- TODO! the folloing helper functions are just to remove the "schema" part when the table is "source" which is the name
@@ -206,31 +208,31 @@ requestToQuery schema (Node (Select colSelects tbls conditions ord, (mainTbl, _)
orderF (fromMaybe [] ord)
]
(withs, selects) = foldr getQueryParts ([],[]) forest
getQueryParts :: Tree ApiNode -> ([SqlFragment], [SqlFragment]) -> ([SqlFragment], [SqlFragment])
getQueryParts :: Tree ReadNode -> ([SqlFragment], [SqlFragment]) -> ([SqlFragment], [SqlFragment])
getQueryParts (Node n@(_, (table, Just (Relation {relType=Child}))) forst) (w,s) = (w,sel:s)
where
sel = "("
<> "SELECT array_to_json(array_agg(row_to_json("<>table<>"))) "
<> "FROM (" <> subquery <> ") " <> table
<> ") AS " <> table
where subquery = requestToQuery schema (Node n forst)
where subquery = requestToQuery schema (DbRead (Node n forst))
getQueryParts (Node n@(_, (table, Just (Relation {relType=Parent}))) forst) (w,s) = (wit:w,sel:s)
where
sel = "row_to_json(" <> table <> ".*) AS "<>table --TODO must be singular
wit = table <> " AS ( " <> subquery <> " )"
where subquery = requestToQuery schema (Node n forst)
where subquery = requestToQuery schema (DbRead (Node n forst))
getQueryParts (Node n@(_, (table, Just (Relation {relType=Many}))) forst) (w,s) = (w,sel:s)
where
sel = "("
<> "SELECT array_to_json(array_agg(row_to_json("<>table<>"))) "
<> "FROM (" <> subquery <> ") " <> table
<> ") AS " <> table
where subquery = requestToQuery schema (Node n forst)
where subquery = requestToQuery schema (DbRead (Node n forst))
--the following is just to remove the warning
--getQueryParts is not total but requestToQuery is called only after addJoinConditions which ensures the only
--posible relations are Child Parent Many
getQueryParts (Node (_,(_,Nothing)) _) _ = undefined
requestToQuery schema (Node (Insert _ (PayloadJSON (UniformObjects rows)), (mainTbl, _)) _) =
requestToQuery schema (DbMutate (Insert mainTbl (PayloadJSON (UniformObjects rows)))) =
let qi = QualifiedIdentifier schema mainTbl
cols = map pgFmtIdent $ fromMaybe [] (HM.keys <$> (rows V.!? 0))
colsString = intercalate ", " cols in
@@ -241,22 +243,22 @@ requestToQuery schema (Node (Insert _ (PayloadJSON (UniformObjects rows)), (main
" FROM json_populate_recordset(null::" , fromQi qi, ", ?)",
" RETURNING " <> fromQi qi <> ".*"
]
requestToQuery schema (Node (Update _ (PayloadJSON (UniformObjects rows)) conditions, (mainTbl, _)) _) =
requestToQuery schema (DbMutate (Update mainTbl (PayloadJSON (UniformObjects rows)) conditions)) =
case rows V.!? 0 of
Just obj ->
let assignments = map
(\(k,v) -> pgFmtIdent k <> "=" <> insertableValue v) $ HM.toList obj in
unwords [
"UPDATE ", fromQi qi,
" SET " <> (intercalate "," assignments) <> " ",
" SET " <> intercalate "," assignments <> " ",
("WHERE " <> intercalate " AND " ( map (pgFmtCondition qi ) conditions )) `emptyOnNull` conditions,
"RETURNING " <> fromQi qi <> ".*"
]
Nothing -> ""
Nothing -> undefined
where
qi = QualifiedIdentifier schema mainTbl
requestToQuery schema (Node (Delete _ conditions, (mainTbl, _)) _) =
requestToQuery schema (DbMutate (Delete mainTbl conditions)) =
query
where
qi = QualifiedIdentifier schema mainTbl
src/PostgREST/Types.hs
+8 -6
View File
@@ -106,13 +106,15 @@ type Cast = Text
type NodeName = Text
type SelectItem = (Field, Maybe Cast)
type Path = [Text]
data Query = Select { select::[SelectItem], from::[Text], where_::[Filter], order::Maybe [OrderTerm] }
| Insert { into::Text, qPayload::Payload }
| Delete { from::[Text], where_::[Filter] }
| Update { into::Text, qPayload::Payload, where_::[Filter] } deriving (Show, Eq)
data ReadQuery = Select { select::[SelectItem], from::[Text], flt_::[Filter], order::Maybe [OrderTerm] } deriving (Show, Eq)
data MutateQuery = Insert { in_::Text, qPayload::Payload }
| Delete { in_::Text, where_::[Filter] }
| Update { in_::Text, qPayload::Payload, where_::[Filter] } deriving (Show, Eq)
data Filter = Filter {field::Field, operator::Operator, value::FValue} deriving (Show, Eq)
type ApiNode = (Query, (NodeName, Maybe Relation))
type ApiRequest = Tree ApiNode
type ReadNode = (ReadQuery, (NodeName, Maybe Relation))
type ReadRequest = Tree ReadNode
type MutateRequest = MutateQuery
data DbRequest = DbRead ReadRequest | DbMutate MutateRequest
instance ToJSON Column where