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

Move DbRequest building functions to new module (#787)

Browse Source
This commit is contained in:
Steve Chávez
2017-01-17 21:59:59 -08:00
committed by Joe Nelson
parent 7e2cb5fe1c
commit c15f693dbb
4 changed files with 283 additions and 262 deletions
Download Patch File Download Diff File Expand all files Collapse all files
postgrest.cabal
+1
View File
@@ -93,6 +93,7 @@ library
, PostgREST.Auth
, PostgREST.Config
, PostgREST.DbStructure
, PostgREST.DbRequestBuilder
, PostgREST.Error
, PostgREST.Middleware
, PostgREST.OpenAPI
src/PostgREST/App.hs
+5 -175
View File
@@ -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, [], "")
src/PostgREST/DbRequestBuilder.hs
+275
View File
@@ -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
src/PostgREST/QueryBuilder.hs
+2 -87
View File
@@ -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 =