diff --git a/postgrest.cabal b/postgrest.cabal index e76a2e824..e458c732a 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -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 diff --git a/src/PostgREST/RequestIntent.hs b/src/PostgREST/ApiRequest.hs similarity index 97% rename from src/PostgREST/RequestIntent.hs rename to src/PostgREST/ApiRequest.hs index 69d62b696..ce228b948 100644 --- a/src/PostgREST/RequestIntent.hs +++ b/src/PostgREST/ApiRequest.hs @@ -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 diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 3d7525028..e16ba5056 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -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 ( diff --git a/src/PostgREST/Middleware.hs b/src/PostgREST/Middleware.hs index 495cfd5ab..0a3885e19 100644 --- a/src/PostgREST/Middleware.hs +++ b/src/PostgREST/Middleware.hs @@ -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) diff --git a/src/PostgREST/Parsers.hs b/src/PostgREST/Parsers.hs index d58a46d0b..e6fbe30a9 100644 --- a/src/PostgREST/Parsers.hs +++ b/src/PostgREST/Parsers.hs @@ -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 diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs index 812c00cf4..b4a25bc81 100644 --- a/src/PostgREST/QueryBuilder.hs +++ b/src/PostgREST/QueryBuilder.hs @@ -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 diff --git a/src/PostgREST/Types.hs b/src/PostgREST/Types.hs index e9a6ad586..2737ca386 100644 --- a/src/PostgREST/Types.hs +++ b/src/PostgREST/Types.hs @@ -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