diff --git a/postgrest.cabal b/postgrest.cabal index 2e68d77f8..ac22cb0dc 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -93,6 +93,7 @@ library , PostgREST.Auth , PostgREST.Config , PostgREST.DbStructure + , PostgREST.DbRequestBuilder , PostgREST.Error , PostgREST.Middleware , PostgREST.OpenAPI diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 6fc04e959..f804cba4f 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -7,23 +7,15 @@ module PostgREST.App ( ) where import Control.Applicative -import Control.Lens.Getter (view) -import Control.Lens.Tuple (_1) import qualified Data.ByteString.Char8 as BS import Data.IORef (IORef, readIORef) -import Data.List (delete, lookup) -import Data.Maybe (fromJust) -import Data.Text (isInfixOf, dropWhile, drop, intercalate) +import Data.Text (intercalate) import Data.Time.Clock.POSIX (POSIXTime) -import Data.Tree -import Data.Either.Combinators (mapLeft) import qualified Hasql.Pool as P import qualified Hasql.Transaction as HT import qualified Hasql.Transaction.Sessions as HT -import Text.Parsec.Error - import Network.HTTP.Types.Header import Network.HTTP.Types.Status import Network.HTTP.Types.URI (renderSimpleQuery) @@ -47,16 +39,13 @@ import PostgREST.ApiRequest ( ApiRequest(..), ContentType(..) import PostgREST.Auth (jwtClaims, containsRole) import PostgREST.Config (AppConfig (..)) import PostgREST.DbStructure -import PostgREST.Error (errResponse, pgErrResponse, apiRequestErrResponse, singularityError, formatParserError) -import PostgREST.Parsers -import PostgREST.RangeQuery (NonnegRange, allRange, rangeOffset, restrictRange) +import PostgREST.DbRequestBuilder(readRequest, mutateRequest) +import PostgREST.Error (errResponse, pgErrResponse, apiRequestErrResponse, singularityError) +import PostgREST.RangeQuery (allRange, rangeOffset) import PostgREST.Middleware import PostgREST.QueryBuilder ( callProc - , addJoinConditions - , sourceCTEName , requestToQuery , requestToCountQuery - , addRelations , createReadStatement , createWriteStatement , ResultsWithCount @@ -64,9 +53,8 @@ import PostgREST.QueryBuilder ( callProc import PostgREST.Types import PostgREST.OpenAPI -import Data.Foldable (foldr1) import Data.Function (id) -import Protolude hiding (dropWhile, drop, intercalate, Proxy) +import Protolude hiding (intercalate, Proxy) postgrest :: AppConfig -> IORef DbStructure -> P.Pool -> IO POSIXTime -> Application @@ -297,7 +285,6 @@ responseContentTypeOrError accepts action = serves contentTypesForRequest accept "None of these Content-Types are available: " <> failed Just ct -> Right ct - splitKeyValue :: BS.ByteString -> (BS.ByteString, BS.ByteString) splitKeyValue kv = (k, BS.tail v) where (k, v) = BS.break (== '=') kv @@ -325,162 +312,5 @@ contentRangeH lower upper total = totalNotZero = fromMaybe True ((/=) 0 <$> total) fromInRange = lower <= upper -augumentRequestWithJoin :: Schema -> [Relation] -> ReadRequest -> Either Text ReadRequest -augumentRequestWithJoin schema allRels request = - (first formatRelationError . addRelations schema allRels Nothing) request - >>= addJoinConditions schema - where - formatRelationError = ("could not find foreign keys between these entities, " <>) - -addFiltersOrdersRanges :: ApiRequest -> Either ParseError (ReadRequest -> ReadRequest) -addFiltersOrdersRanges apiRequest = foldr1 (liftA2 (.)) [ - flip (foldr addFilter) <$> filters, - flip (foldr addOrder) <$> orders, - flip (foldr addRange) <$> ranges - ] - {- - The esence of what is going on above is that we are composing tree functions - of type (ReadRequest->ReadRequest) that are in (Either ParseError a) context - -} - where - filters :: Either ParseError [(Path, Filter)] - filters = mapM pRequestFilter flts - where - action = iAction apiRequest - flts - | action == ActionRead = iFilters apiRequest - | action == ActionInvoke = iFilters apiRequest - | otherwise = filter (( "." `isInfixOf` ) . fst) $ iFilters apiRequest -- there can be no filters on the root table whre we are doing insert/update - orders :: Either ParseError [(Path, [OrderTerm])] - orders = mapM pRequestOrder $ iOrder apiRequest - ranges :: Either ParseError [(Path, NonnegRange)] - ranges = mapM pRequestRange $ M.toList $ iRange apiRequest - -treeRestrictRange :: Maybe Integer -> ReadRequest -> Either Text ReadRequest -treeRestrictRange maxRows_ request = pure $ nodeRestrictRange maxRows_ `fmap` request - where - nodeRestrictRange :: Maybe Integer -> ReadNode -> ReadNode - nodeRestrictRange m (q@Select {range_=r}, i) = (q{range_=restrictRange m r }, i) - -readRequest :: Maybe Integer -> [Relation] -> [(Text, Text)] -> ApiRequest -> Either Response ReadRequest -readRequest maxRows allRels allProcs apiRequest = - mapLeft (errResponse status400) $ - treeRestrictRange maxRows =<< - augumentRequestWithJoin schema relations =<< - first formatParserError parseReadRequest - where - (schema, rootTableName) = fromJust $ -- Make it safe - let target = iTarget apiRequest in - case target of - (TargetIdent (QualifiedIdentifier s t) ) -> Just (s, t) - (TargetProc (QualifiedIdentifier s p) ) -> Just (s, t) - where - returnType = fromMaybe "" $ lookup p allProcs - -- we are looking for results looking like "SETOF schema.tablename" and want to extract tablename - t = if "SETOF " `isInfixOf` returnType - then drop 1 $ dropWhile (/= '.') returnType - else p - - _ -> Nothing - - action :: Action - action = iAction apiRequest - - parseReadRequest :: Either ParseError ReadRequest - parseReadRequest = addFiltersOrdersRanges apiRequest <*> - pRequestSelect rootName selStr - where - selStr = iSelect apiRequest - rootName = if action == ActionRead - then rootTableName - else sourceCTEName - - relations :: [Relation] - relations = case action of - ActionCreate -> fakeSourceRelations ++ allRels - ActionUpdate -> fakeSourceRelations ++ allRels - ActionDelete -> fakeSourceRelations ++ allRels - ActionInvoke -> fakeSourceRelations ++ allRels - _ -> allRels - where fakeSourceRelations = mapMaybe (toSourceRelation rootTableName) allRels -- see comment in toSourceRelation - -mutateRequest :: ApiRequest -> ReadRequest -> Either Response MutateRequest -mutateRequest apiRequest readReq = mapLeft (errResponse status400) $ - case action of - ActionCreate -> Right $ Insert rootTableName payload returnings - ActionUpdate -> Update rootTableName <$> pure payload <*> filters <*> pure returnings - ActionDelete -> Delete rootTableName <$> filters <*> pure returnings - _ -> Left "Unsupported HTTP verb" - where - action = iAction apiRequest - payload = fromJust $ iPayload apiRequest - rootTableName = -- TODO: Make it safe - let target = iTarget apiRequest in - case target of - (TargetIdent (QualifiedIdentifier _ t) ) -> t - _ -> undefined - fieldNames :: ReadRequest -> PreferRepresentation -> [FieldName] - fieldNames _ None = [] - fieldNames (Node (sel, _) forest) _ = - map (fst . view _1) (select sel) ++ map colName fks - where - fks = concatMap (fromMaybe [] . f) forest - f (Node (_, (_, Just Relation{relFColumns=cols, relType=Parent}, _)) _) = Just cols - f _ = Nothing - returnings = fieldNames readReq (iPreferRepresentation apiRequest) - filters = first formatParserError $ map snd <$> mapM pRequestFilter mutateFilters - where mutateFilters = filter (not . ( "." `isInfixOf` ) . fst) $ iFilters apiRequest -- update/delete filters can be only on the root table - -addFilterToNode :: Filter -> ReadRequest -> ReadRequest -addFilterToNode flt (Node (q@Select {flt_=flts}, i) f) = Node (q {flt_=flt:flts}, i) f - -addFilter :: (Path, Filter) -> ReadRequest -> ReadRequest -addFilter = addProperty addFilterToNode - -addOrderToNode :: [OrderTerm] -> ReadRequest -> ReadRequest -addOrderToNode o (Node (q,i) f) = Node (q{order=Just o}, i) f - -addOrder :: (Path, [OrderTerm]) -> ReadRequest -> ReadRequest -addOrder = addProperty addOrderToNode - -addRangeToNode :: NonnegRange -> ReadRequest -> ReadRequest -addRangeToNode r (Node (q,i) f) = Node (q{range_=r}, i) f - -addRange :: (Path, NonnegRange) -> ReadRequest -> ReadRequest -addRange = addProperty addRangeToNode - -addProperty :: (a -> ReadRequest -> ReadRequest) -> (Path, a) -> ReadRequest -> ReadRequest -addProperty f ([], a) n = f a n -addProperty f (path, a) (Node rn forest) = - case targetNode of - Nothing -> Node rn forest -- the property is silenty dropped in the Request does not contain the required path - Just tn -> Node rn (addProperty f (remainingPath, a) tn:restForest) - where - targetNodeName:remainingPath = path - (targetNode,restForest) = splitForest targetNodeName forest - splitForest :: NodeName -> Forest ReadNode -> (Maybe ReadRequest, Forest ReadNode) - splitForest name forst = - case maybeNode of - Nothing -> (Nothing,forest) - Just node -> (Just node, delete node forest) - where - maybeNode :: Maybe ReadRequest - maybeNode = find fnd forst - where - fnd :: ReadRequest -> Bool - fnd (Node (_,(n,_,_)) _) = n == name - --- in a relation where one of the tables mathces "TableName" --- replace the name to that table with pg_source --- this "fake" relations is needed so that in a mutate query --- we can look a the "returning *" part which is wrapped with a "with" --- as just another table that has relations with other tables -toSourceRelation :: TableName -> Relation -> Maybe Relation -toSourceRelation mt r@(Relation t _ ft _ _ rt _ _) - | mt == tableName t = Just $ r {relTable=t {tableName=sourceCTEName}} - | mt == tableName ft = Just $ r {relFTable=t {tableName=sourceCTEName}} - | Just mt == (tableName <$> rt) = Just $ r {relLTable=(\tbl -> tbl {tableName=sourceCTEName}) <$> rt} - | otherwise = Nothing - extractQueryResult :: Maybe ResultsWithCount -> ResultsWithCount extractQueryResult = fromMaybe (Nothing, 0, [], "") diff --git a/src/PostgREST/DbRequestBuilder.hs b/src/PostgREST/DbRequestBuilder.hs new file mode 100644 index 000000000..a51d9cdba --- /dev/null +++ b/src/PostgREST/DbRequestBuilder.hs @@ -0,0 +1,275 @@ +{-# LANGUAGE FlexibleContexts #-} +module PostgREST.DbRequestBuilder ( + readRequest +, mutateRequest +) where + +import Control.Applicative +import Control.Lens.Getter (view) +import Control.Lens.Tuple (_1) +import qualified Data.ByteString.Char8 as BS +import Data.List (delete, lookup) +import Data.Maybe (fromJust) +import Data.Text (isInfixOf, dropWhile, drop) +import Data.Tree +import Data.Either.Combinators (mapLeft) + +import Text.Parsec.Error + +import Network.HTTP.Types.Status +import Network.Wai + +import Data.Foldable (foldr1) +import qualified Data.HashMap.Strict as M + +import PostgREST.ApiRequest ( ApiRequest(..) + , Action(..), Target(..) + , PreferRepresentation (..) + ) +import PostgREST.Error (errResponse, formatParserError) +import PostgREST.Parsers +import PostgREST.RangeQuery (NonnegRange, restrictRange) +import PostgREST.QueryBuilder (getJoinConditions, sourceCTEName) +import PostgREST.Types + +import Protolude hiding (from, dropWhile, drop) +import Text.Regex.TDFA ((=~)) +import Unsafe (unsafeHead) + +readRequest :: Maybe Integer -> [Relation] -> [(Text, Text)] -> ApiRequest -> Either Response ReadRequest +readRequest maxRows allRels allProcs apiRequest = + mapLeft (errResponse status400) $ + treeRestrictRange maxRows =<< + augumentRequestWithJoin schema relations =<< + first formatParserError parseReadRequest + where + (schema, rootTableName) = fromJust $ -- Make it safe + let target = iTarget apiRequest in + case target of + (TargetIdent (QualifiedIdentifier s t) ) -> Just (s, t) + (TargetProc (QualifiedIdentifier s p) ) -> Just (s, t) + where + returnType = fromMaybe "" $ lookup p allProcs + -- we are looking for results looking like "SETOF schema.tablename" and want to extract tablename + t = if "SETOF " `isInfixOf` returnType + then drop 1 $ dropWhile (/= '.') returnType + else p + + _ -> Nothing + + action :: Action + action = iAction apiRequest + + parseReadRequest :: Either ParseError ReadRequest + parseReadRequest = addFiltersOrdersRanges apiRequest <*> + pRequestSelect rootName selStr + where + selStr = iSelect apiRequest + rootName = if action == ActionRead + then rootTableName + else sourceCTEName + + relations :: [Relation] + relations = case action of + ActionCreate -> fakeSourceRelations ++ allRels + ActionUpdate -> fakeSourceRelations ++ allRels + ActionDelete -> fakeSourceRelations ++ allRels + ActionInvoke -> fakeSourceRelations ++ allRels + _ -> allRels + where fakeSourceRelations = mapMaybe (toSourceRelation rootTableName) allRels -- see comment in toSourceRelation + +treeRestrictRange :: Maybe Integer -> ReadRequest -> Either Text ReadRequest +treeRestrictRange maxRows_ request = pure $ nodeRestrictRange maxRows_ `fmap` request + where + nodeRestrictRange :: Maybe Integer -> ReadNode -> ReadNode + nodeRestrictRange m (q@Select {range_=r}, i) = (q{range_=restrictRange m r }, i) + +augumentRequestWithJoin :: Schema -> [Relation] -> ReadRequest -> Either Text ReadRequest +augumentRequestWithJoin schema allRels request = + (first formatRelationError . addRelations schema allRels Nothing) request + >>= addJoinConditions schema + where + formatRelationError = ("could not find foreign keys between these entities, " <>) + +addRelations :: Schema -> [Relation] -> Maybe ReadRequest -> ReadRequest -> Either Text ReadRequest +addRelations schema allRelations parentNode (Node readNode@(query, (name, _, alias)) forest) = + case parentNode of + (Just (Node (Select{from=[parentNodeTable]}, (_, _, _)) _)) -> + Node <$> readNode' <*> forest' + where + forest' = updateForest $ hush node' + node' = Node <$> readNode' <*> pure forest + readNode' = addRel readNode <$> rel + rel :: Either Text Relation + rel = note ("no relation between " <> parentNodeTable <> " and " <> name) + $ findRelation schema name parentNodeTable + + where + findRelation s nodeTableName parentNodeTableName = + find (\r -> + s == tableSchema (relTable r) && -- match schema for relation table + s == tableSchema (relFTable r) && -- match schema for relation foriegn table + ( + + -- (request) => projects { ..., clients{...} } + -- will match + -- (relation type) => parent + -- (entity) => clients {id} + -- (foriegn entity) => projects {client_id} + ( + nodeTableName == tableName (relTable r) && -- match relation table name + parentNodeTableName == tableName (relFTable r) -- match relation foreign table name + ) || + + + -- (request) => projects { ..., client_id{...} } + -- will match + -- (relation type) => parent + -- (entity) => clients {id} + -- (foriegn entity) => projects {client_id} + ( + parentNodeTableName == tableName (relFTable r) && + length (relFColumns r) == 1 && + nodeTableName `colMatches` (colName . unsafeHead . relFColumns) r + ) + + -- (request) => project_id { ..., client_id{...} } + -- will match + -- (relation type) => parent + -- (entity) => clients {id} + -- (foriegn entity) => projects {client_id} + -- this case works becasue before reaching this place + -- addRelation will turn project_id to project so the above condition will match + ) + ) allRelations + where n `colMatches` rc = (toS ("^" <> rc <> "_?(?:|[iI][dD]|[fF][kK])$") :: BS.ByteString) =~ (toS n :: BS.ByteString) + addRel :: (ReadQuery, (NodeName, Maybe Relation, Maybe Alias)) -> Relation -> (ReadQuery, (NodeName, Maybe Relation, Maybe Alias)) + addRel (query', (n, _, a)) r = (query' {from=fromRelation}, (n, Just r, a)) + where fromRelation = map (\t -> if t == n then tableName (relTable r) else t) (from query') + + _ -> n' <$> updateForest (Just (n' forest)) + where + n' = Node (query, (name, Just r, alias)) + t = Table schema name True -- !!! TODO find another way to get the table from the query + r = Relation t [] t [] Root Nothing Nothing Nothing + where + updateForest :: Maybe ReadRequest -> Either Text [ReadRequest] + updateForest n = mapM (addRelations schema allRelations n) forest + +addJoinConditions :: Schema -> ReadRequest -> Either Text ReadRequest +addJoinConditions schema (Node nn@(query, (n, r, a)) forest) = + case r of + Just Relation{relType=Root} -> Node nn <$> updatedForest -- this is the root node + Just rel@Relation{relType=Child} -> Node (addCond query (getJoinConditions rel),(n,r,a)) <$> updatedForest + Just Relation{relType=Parent} -> Node nn <$> updatedForest + Just rel@Relation{relType=Many, relLTable=(Just linkTable)} -> + Node (qq, (n, r, a)) <$> updatedForest + where + query' = addCond query (getJoinConditions rel) + qq = query'{from=tableName linkTable : from query'} + _ -> Left "unknown relation" + where + updatedForest = mapM (addJoinConditions schema) forest + addCond query' con = query'{flt_=con ++ flt_ query'} + +addFiltersOrdersRanges :: ApiRequest -> Either ParseError (ReadRequest -> ReadRequest) +addFiltersOrdersRanges apiRequest = foldr1 (liftA2 (.)) [ + flip (foldr addFilter) <$> filters, + flip (foldr addOrder) <$> orders, + flip (foldr addRange) <$> ranges + ] + {- + The esence of what is going on above is that we are composing tree functions + of type (ReadRequest->ReadRequest) that are in (Either ParseError a) context + -} + where + filters :: Either ParseError [(Path, Filter)] + filters = mapM pRequestFilter flts + where + action = iAction apiRequest + flts + | action == ActionRead = iFilters apiRequest + | action == ActionInvoke = iFilters apiRequest + | otherwise = filter (( "." `isInfixOf` ) . fst) $ iFilters apiRequest -- there can be no filters on the root table whre we are doing insert/update + orders :: Either ParseError [(Path, [OrderTerm])] + orders = mapM pRequestOrder $ iOrder apiRequest + ranges :: Either ParseError [(Path, NonnegRange)] + ranges = mapM pRequestRange $ M.toList $ iRange apiRequest + +addFilterToNode :: Filter -> ReadRequest -> ReadRequest +addFilterToNode flt (Node (q@Select {flt_=flts}, i) f) = Node (q {flt_=flt:flts}, i) f + +addFilter :: (Path, Filter) -> ReadRequest -> ReadRequest +addFilter = addProperty addFilterToNode + +addOrderToNode :: [OrderTerm] -> ReadRequest -> ReadRequest +addOrderToNode o (Node (q,i) f) = Node (q{order=Just o}, i) f + +addOrder :: (Path, [OrderTerm]) -> ReadRequest -> ReadRequest +addOrder = addProperty addOrderToNode + +addRangeToNode :: NonnegRange -> ReadRequest -> ReadRequest +addRangeToNode r (Node (q,i) f) = Node (q{range_=r}, i) f + +addRange :: (Path, NonnegRange) -> ReadRequest -> ReadRequest +addRange = addProperty addRangeToNode + +addProperty :: (a -> ReadRequest -> ReadRequest) -> (Path, a) -> ReadRequest -> ReadRequest +addProperty f ([], a) n = f a n +addProperty f (path, a) (Node rn forest) = + case targetNode of + Nothing -> Node rn forest -- the property is silenty dropped in the Request does not contain the required path + Just tn -> Node rn (addProperty f (remainingPath, a) tn:restForest) + where + targetNodeName:remainingPath = path + (targetNode,restForest) = splitForest targetNodeName forest + splitForest :: NodeName -> Forest ReadNode -> (Maybe ReadRequest, Forest ReadNode) + splitForest name forst = + case maybeNode of + Nothing -> (Nothing,forest) + Just node -> (Just node, delete node forest) + where + maybeNode :: Maybe ReadRequest + maybeNode = find fnd forst + where + fnd :: ReadRequest -> Bool + fnd (Node (_,(n,_,_)) _) = n == name + +-- in a relation where one of the tables mathces "TableName" +-- replace the name to that table with pg_source +-- this "fake" relations is needed so that in a mutate query +-- we can look a the "returning *" part which is wrapped with a "with" +-- as just another table that has relations with other tables +toSourceRelation :: TableName -> Relation -> Maybe Relation +toSourceRelation mt r@(Relation t _ ft _ _ rt _ _) + | mt == tableName t = Just $ r {relTable=t {tableName=sourceCTEName}} + | mt == tableName ft = Just $ r {relFTable=t {tableName=sourceCTEName}} + | Just mt == (tableName <$> rt) = Just $ r {relLTable=(\tbl -> tbl {tableName=sourceCTEName}) <$> rt} + | otherwise = Nothing + +mutateRequest :: ApiRequest -> ReadRequest -> Either Response MutateRequest +mutateRequest apiRequest readReq = mapLeft (errResponse status400) $ + case action of + ActionCreate -> Right $ Insert rootTableName payload returnings + ActionUpdate -> Update rootTableName <$> pure payload <*> filters <*> pure returnings + ActionDelete -> Delete rootTableName <$> filters <*> pure returnings + _ -> Left "Unsupported HTTP verb" + where + action = iAction apiRequest + payload = fromJust $ iPayload apiRequest + rootTableName = -- TODO: Make it safe + let target = iTarget apiRequest in + case target of + (TargetIdent (QualifiedIdentifier _ t) ) -> t + _ -> undefined + fieldNames :: ReadRequest -> PreferRepresentation -> [FieldName] + fieldNames _ None = [] + fieldNames (Node (sel, _) forest) _ = + map (fst . view _1) (select sel) ++ map colName fks + where + fks = concatMap (fromMaybe [] . f) forest + f (Node (_, (_, Just Relation{relFColumns=cols, relType=Parent}, _)) _) = Just cols + f _ = Nothing + returnings = fieldNames readReq (iPreferRepresentation apiRequest) + filters = first formatParserError $ map snd <$> mapM pRequestFilter mutateFilters + where mutateFilters = filter (not . ( "." `isInfixOf` ) . fst) $ iFilters apiRequest -- update/delete filters can be only on the root table diff --git a/src/PostgREST/QueryBuilder.hs b/src/PostgREST/QueryBuilder.hs index 958d45d6a..eb30d90a6 100644 --- a/src/PostgREST/QueryBuilder.hs +++ b/src/PostgREST/QueryBuilder.hs @@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-| @@ -13,11 +12,10 @@ and produces SQL Statements. Any function that outputs a SQL fragment should be in this module. -} module PostgREST.QueryBuilder ( - addRelations - , addJoinConditions - , callProc + callProc , createReadStatement , createWriteStatement + , getJoinConditions , operators , pgFmtIdent , pgFmtLit @@ -45,7 +43,6 @@ import qualified Data.Vector as V import PostgREST.Types import qualified Data.Map as M import Text.InterpolatedString.Perl6 (qc) -import Text.Regex.TDFA ((=~)) import qualified Data.ByteString.Char8 as BS import Data.Scientific ( FPFormat (..) , formatScientific @@ -53,7 +50,6 @@ import Data.Scientific ( FPFormat (..) ) import Protolude hiding (from, intercalate, ord, cast) import PostgREST.ApiRequest (PreferRepresentation (..)) -import Unsafe (unsafeHead) {-| The generic query result format used by API responses. The location header is represented as a list of strings containing variable bindings like @@ -146,87 +142,6 @@ createWriteStatement selectQuery mutateQuery wantSingle wantHdrs asCsv rep pKeys | wantSingle = asJsonSingleF | otherwise = asJsonF -addRelations :: Schema -> [Relation] -> Maybe ReadRequest -> ReadRequest -> Either Text ReadRequest -addRelations schema allRelations parentNode (Node readNode@(query, (name, _, alias)) forest) = - case parentNode of - (Just (Node (Select{from=[parentNodeTable]}, (_, _, _)) _)) -> - Node <$> readNode' <*> forest' - where - forest' = updateForest $ hush node' - node' = Node <$> readNode' <*> pure forest - readNode' = addRel readNode <$> rel - rel :: Either Text Relation - rel = note ("no relation between " <> parentNodeTable <> " and " <> name) - $ findRelation schema name parentNodeTable - - where - findRelation s nodeTableName parentNodeTableName = - find (\r -> - s == tableSchema (relTable r) && -- match schema for relation table - s == tableSchema (relFTable r) && -- match schema for relation foriegn table - ( - - -- (request) => projects { ..., clients{...} } - -- will match - -- (relation type) => parent - -- (entity) => clients {id} - -- (foriegn entity) => projects {client_id} - ( - nodeTableName == tableName (relTable r) && -- match relation table name - parentNodeTableName == tableName (relFTable r) -- match relation foreign table name - ) || - - - -- (request) => projects { ..., client_id{...} } - -- will match - -- (relation type) => parent - -- (entity) => clients {id} - -- (foriegn entity) => projects {client_id} - ( - parentNodeTableName == tableName (relFTable r) && - length (relFColumns r) == 1 && - nodeTableName `colMatches` (colName . unsafeHead . relFColumns) r - ) - - -- (request) => project_id { ..., client_id{...} } - -- will match - -- (relation type) => parent - -- (entity) => clients {id} - -- (foriegn entity) => projects {client_id} - -- this case works becasue before reaching this place - -- addRelation will turn project_id to project so the above condition will match - ) - ) allRelations - where n `colMatches` rc = (toS ("^" <> rc <> "_?(?:|[iI][dD]|[fF][kK])$") :: BS.ByteString) =~ (toS n :: BS.ByteString) - addRel :: (ReadQuery, (NodeName, Maybe Relation, Maybe Alias)) -> Relation -> (ReadQuery, (NodeName, Maybe Relation, Maybe Alias)) - addRel (query', (n, _, a)) r = (query' {from=fromRelation}, (n, Just r, a)) - where fromRelation = map (\t -> if t == n then tableName (relTable r) else t) (from query') - - _ -> n' <$> updateForest (Just (n' forest)) - where - n' = Node (query, (name, Just r, alias)) - t = Table schema name True -- !!! TODO find another way to get the table from the query - r = Relation t [] t [] Root Nothing Nothing Nothing - where - updateForest :: Maybe ReadRequest -> Either Text [ReadRequest] - updateForest n = mapM (addRelations schema allRelations n) forest - -addJoinConditions :: Schema -> ReadRequest -> Either Text ReadRequest -addJoinConditions schema (Node nn@(query, (n, r, a)) forest) = - case r of - Just Relation{relType=Root} -> Node nn <$> updatedForest -- this is the root node - Just rel@Relation{relType=Child} -> Node (addCond query (getJoinConditions rel),(n,r,a)) <$> updatedForest - Just Relation{relType=Parent} -> Node nn <$> updatedForest - Just rel@Relation{relType=Many, relLTable=(Just linkTable)} -> - Node (qq, (n, r, a)) <$> updatedForest - where - query' = addCond query (getJoinConditions rel) - qq = query'{from=tableName linkTable : from query'} - _ -> Left "unknown relation" - where - updatedForest = mapM (addJoinConditions schema) forest - addCond query' con = query'{flt_=con ++ flt_ query'} - type ProcResults = (Maybe Int64, Int64, ByteString) callProc :: QualifiedIdentifier -> JSON.Object -> SqlQuery -> SqlQuery -> NonnegRange -> Bool -> Bool -> Bool -> H.Query () (Maybe ProcResults) callProc qi params selectQuery countQuery _ countTotal isSingle paramsAsJson =