mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-11-13 09:17:21 +03:00
refactor select query generation (#941)
This commit is contained in:
Rakesh Emmadi
Shahidh K Muhammed
parent
a32d94f841
commit
0803738df1
@ -165,6 +165,7 @@ library
|
||||
, Hasura.RQL.DML.Internal
|
||||
, Hasura.RQL.DML.Insert
|
||||
, Hasura.RQL.DML.Returning
|
||||
, Hasura.RQL.DML.Select.Internal
|
||||
, Hasura.RQL.DML.Select
|
||||
, Hasura.RQL.DML.Update
|
||||
, Hasura.RQL.DML.Count
|
||||
|
||||
@ -80,7 +80,7 @@ explainField userInfo gCtx fld =
|
||||
RS.fromFieldByPKey txtConverter tn permFilter fld
|
||||
OCSelectAgg tn permFilter permLimit hdrs -> do
|
||||
validateHdrs hdrs
|
||||
RS.mkSQLSelect False <$>
|
||||
RS.mkAggSelect <$>
|
||||
RS.fromAggField txtConverter tn permFilter permLimit fld
|
||||
_ -> throw500 "unexpected mut field info for explain"
|
||||
|
||||
|
||||
@ -410,14 +410,13 @@ execWithExp
|
||||
-> AnnSelFlds
|
||||
-> Q.TxE QErr RespBody
|
||||
execWithExp tn (withExp, args) annFlds = do
|
||||
let annSel = RS.AnnSel selFlds tabFrom tabPerm RS.noTableArgs
|
||||
let annSel = RS.AnnSelG annFlds tabFrom tabPerm RS.noTableArgs
|
||||
sqlSel = RS.mkSQLSelect True annSel
|
||||
selWith = S.SelectWith [(alias, withExp)] sqlSel
|
||||
sqlBuilder = toSQL selWith
|
||||
runIdentity . Q.getRow
|
||||
<$> Q.rawQE dmlTxErrorHandler (Q.fromBuilder sqlBuilder) (toList args) True
|
||||
where
|
||||
selFlds = RS.ASFSimple annFlds
|
||||
tabFrom = RS.TableFrom tn frmItemM
|
||||
tabPerm = RS.TablePerm (S.BELit True) Nothing
|
||||
alias = S.Alias $ Iden $ snakeCaseTable tn <> "__rel_insert_result"
|
||||
@ -521,7 +520,7 @@ insertMultipleObjects role insCtxMap tn ctx insObjs
|
||||
return $ J.toJSON affRows
|
||||
RR.MExp txt -> return $ J.toJSON txt
|
||||
RR.MRet annSel -> do
|
||||
let annFlds = RS.fetchAnnFlds $ RS._asnFields annSel
|
||||
let annFlds = RS._asnFields annSel
|
||||
bs <- buildReturningResp tn withExps annFlds
|
||||
decodeFromBS bs
|
||||
return (t, jsonVal)
|
||||
|
||||
@ -36,10 +36,9 @@ convertReturning
|
||||
:: QualifiedTable -> G.NamedType -> SelSet -> Convert RS.AnnSel
|
||||
convertReturning qt ty selSet = do
|
||||
annFlds <- fromSelSet prepare ty selSet
|
||||
let selFlds = RS.ASFSimple annFlds
|
||||
tabFrom = RS.TableFrom qt $ Just frmItem
|
||||
let tabFrom = RS.TableFrom qt $ Just frmItem
|
||||
tabPerm = RS.TablePerm (S.BELit True) Nothing
|
||||
return $ RS.AnnSel selFlds tabFrom tabPerm RS.noTableArgs
|
||||
return $ RS.AnnSelG annFlds tabFrom tabPerm RS.noTableArgs
|
||||
where
|
||||
frmItem = S.FIIden $ RR.qualTableToAliasIden qt
|
||||
|
||||
|
||||
@ -63,11 +63,15 @@ fromSelSet f fldTy flds =
|
||||
Left colInfo -> return $ RS.FCol colInfo
|
||||
Right (relInfo, isAgg, tableFilter, tableLimit) -> do
|
||||
let relTN = riRTable relInfo
|
||||
annSelMaker = bool fromField fromAggField isAgg
|
||||
annSel <- annSelMaker f relTN tableFilter tableLimit fld
|
||||
let annRel = RS.AnnRel (riName relInfo) (riType relInfo)
|
||||
(riMapping relInfo) annSel
|
||||
return $ RS.FRel annRel
|
||||
colMapping = riMapping relInfo
|
||||
if isAgg then do
|
||||
aggSel <- fromAggField f relTN tableFilter tableLimit fld
|
||||
return $ RS.FAgg $ RS.AggSel colMapping aggSel
|
||||
else do
|
||||
annSel <- fromField f relTN tableFilter tableLimit fld
|
||||
let annRel = RS.AnnRel (riName relInfo) (riType relInfo)
|
||||
colMapping annSel
|
||||
return $ RS.FRel annRel
|
||||
|
||||
fieldAsPath :: (MonadError QErr m) => Field -> m a -> m a
|
||||
fieldAsPath = nameAsPath . _fName
|
||||
@ -92,10 +96,9 @@ fromField f tn permFilter permLimitM fld =
|
||||
fieldAsPath fld $ do
|
||||
tableArgs <- parseTableArgs f tn args
|
||||
annFlds <- fromSelSet f (_fType fld) $ _fSelSet fld
|
||||
let selFlds = RS.ASFSimple annFlds
|
||||
tabFrom = RS.TableFrom tn Nothing
|
||||
let tabFrom = RS.TableFrom tn Nothing
|
||||
tabPerm = RS.TablePerm permFilter permLimitM
|
||||
return $ RS.AnnSel selFlds tabFrom tabPerm tableArgs
|
||||
return $ RS.AnnSelG annFlds tabFrom tabPerm tableArgs
|
||||
where
|
||||
args = _fArguments fld
|
||||
|
||||
@ -174,10 +177,9 @@ fromFieldByPKey
|
||||
fromFieldByPKey f tn permFilter fld = fieldAsPath fld $ do
|
||||
boolExp <- pgColValToBoolExpG f tn $ _fArguments fld
|
||||
annFlds <- fromSelSet f (_fType fld) $ _fSelSet fld
|
||||
let selFlds = RS.ASFSimple annFlds
|
||||
tabFrom = RS.TableFrom tn Nothing
|
||||
let tabFrom = RS.TableFrom tn Nothing
|
||||
tabPerm = RS.TablePerm permFilter Nothing
|
||||
return $ RS.AnnSel selFlds tabFrom tabPerm $
|
||||
return $ RS.AnnSelG annFlds tabFrom tabPerm $
|
||||
RS.noTableArgs { RS._taWhere = Just boolExp}
|
||||
|
||||
convertSelect
|
||||
@ -224,14 +226,13 @@ convertAggFld ty selSet =
|
||||
fromAggField
|
||||
:: (MonadError QErr m, MonadReader r m, Has FieldMap r, Has OrdByCtx r)
|
||||
=> ((PGColType, PGColValue) -> m S.SQLExp)
|
||||
-> QualifiedTable -> S.BoolExp -> Maybe Int -> Field -> m RS.AnnSel
|
||||
-> QualifiedTable -> S.BoolExp -> Maybe Int -> Field -> m RS.AnnAggSel
|
||||
fromAggField fn tn permFilter permLimitM fld = fieldAsPath fld $ do
|
||||
tableArgs <- parseTableArgs fn tn args
|
||||
aggSelFlds <- fromAggSel (_fType fld) $ _fSelSet fld
|
||||
let selFlds = RS.ASFWithAgg aggSelFlds
|
||||
tabFrom = RS.TableFrom tn Nothing
|
||||
let tabFrom = RS.TableFrom tn Nothing
|
||||
tabPerm = RS.TablePerm permFilter permLimitM
|
||||
return $ RS.AnnSel selFlds tabFrom tabPerm tableArgs
|
||||
return $ RS.AnnSelG aggSelFlds tabFrom tabPerm tableArgs
|
||||
where
|
||||
args = _fArguments fld
|
||||
fromAggSel ty selSet =
|
||||
@ -250,4 +251,4 @@ convertAggSelect qt permFilter permLimit fld = do
|
||||
selData <- withPathK "selectionSet" $
|
||||
fromAggField prepare qt permFilter permLimit fld
|
||||
prepArgs <- get
|
||||
return $ RS.selectP2 False (selData, prepArgs)
|
||||
return $ RS.selectAggP2 (selData, prepArgs)
|
||||
|
||||
@ -29,15 +29,14 @@ pgColsFromMutFld = \case
|
||||
MCount -> []
|
||||
MExp _ -> []
|
||||
MRet selData ->
|
||||
flip mapMaybe ( fetchAnnFlds $ _asnFields selData) $ \(_, annFld) -> case annFld of
|
||||
flip mapMaybe (_asnFields selData) $ \(_, annFld) -> case annFld of
|
||||
FCol (PGColInfo col colTy _) -> Just (col, colTy)
|
||||
_ -> Nothing
|
||||
|
||||
pgColsToSelData :: QualifiedTable -> [PGColInfo] -> AnnSel
|
||||
pgColsToSelData qt cols =
|
||||
AnnSel selFlds tabFrom tabPerm noTableArgs
|
||||
AnnSelG flds tabFrom tabPerm noTableArgs
|
||||
where
|
||||
selFlds = ASFSimple flds
|
||||
tabFrom = TableFrom qt $ Just frmItem
|
||||
tabPerm = TablePerm (S.BELit True) Nothing
|
||||
flds = flip map cols $ \pgColInfo ->
|
||||
|
||||
@ -1,618 +1,39 @@
|
||||
{-# LANGUAGE DeriveLift #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module Hasura.RQL.DML.Select where
|
||||
module Hasura.RQL.DML.Select
|
||||
( selectP2
|
||||
, selectAggP2
|
||||
, mkSQLSelect
|
||||
, mkAggSelect
|
||||
, convSelectQuery
|
||||
, getSelectDeps
|
||||
, module Hasura.RQL.DML.Select.Internal
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Aeson.Types
|
||||
import Data.List (unionBy)
|
||||
import Instances.TH.Lift ()
|
||||
import Language.Haskell.TH.Syntax (Lift)
|
||||
import Data.List (unionBy)
|
||||
import Instances.TH.Lift ()
|
||||
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import qualified Data.HashSet as HS
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import qualified Data.Sequence as DS
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import qualified Data.HashSet as HS
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import qualified Data.Sequence as DS
|
||||
|
||||
import Hasura.Prelude
|
||||
import Hasura.RQL.DML.Internal
|
||||
import Hasura.RQL.DML.Select.Internal
|
||||
import Hasura.RQL.GBoolExp
|
||||
import Hasura.RQL.Types
|
||||
import Hasura.SQL.Rewrite (prefixNumToAliases)
|
||||
import Hasura.SQL.Rewrite (prefixNumToAliases)
|
||||
import Hasura.SQL.Types
|
||||
|
||||
import qualified Database.PG.Query as Q
|
||||
import qualified Hasura.SQL.DML as S
|
||||
|
||||
-- Conversion of SelectQ happens in 2 Stages.
|
||||
-- Stage 1 : Convert input query into an annotated AST
|
||||
-- Stage 2 : Convert annotated AST to SQL Select
|
||||
|
||||
type SelectQExt = SelectG ExtCol BoolExp Int
|
||||
-- Columns in RQL
|
||||
data ExtCol
|
||||
= ECSimple !PGCol
|
||||
| ECRel !RelName !(Maybe RelName) !SelectQExt
|
||||
deriving (Show, Eq, Lift)
|
||||
|
||||
instance ToJSON ExtCol where
|
||||
toJSON (ECSimple s) = toJSON s
|
||||
toJSON (ECRel rn mrn selq) =
|
||||
object $ [ "name" .= rn
|
||||
, "alias" .= mrn
|
||||
] ++ selectGToPairs selq
|
||||
|
||||
instance FromJSON ExtCol where
|
||||
parseJSON v@(Object o) =
|
||||
ECRel
|
||||
<$> o .: "name"
|
||||
<*> o .:? "alias"
|
||||
<*> parseJSON v
|
||||
parseJSON (String s) =
|
||||
return $ ECSimple $ PGCol s
|
||||
parseJSON _ =
|
||||
fail $ mconcat
|
||||
[ "A column should either be a string or an "
|
||||
, "object (relationship)"
|
||||
]
|
||||
|
||||
data AnnRel
|
||||
= AnnRel
|
||||
{ arName :: !RelName -- Relationship name
|
||||
, arType :: !RelType -- Relationship type (ObjRel, ArrRel)
|
||||
, arMapping :: ![(PGCol, PGCol)] -- Column of the left table to join with
|
||||
, arAnnSel :: !AnnSel -- Current table. Almost ~ to SQL Select
|
||||
} deriving (Show, Eq)
|
||||
|
||||
data AnnFld
|
||||
= FCol !PGColInfo
|
||||
| FExp !T.Text
|
||||
| FRel !AnnRel
|
||||
deriving (Show, Eq)
|
||||
|
||||
data TableArgs
|
||||
= TableArgs
|
||||
{ _taWhere :: !(Maybe (GBoolExp AnnSQLBoolExp))
|
||||
, _taOrderBy :: !(Maybe (NE.NonEmpty AnnOrderByItem))
|
||||
, _taLimit :: !(Maybe Int)
|
||||
, _taOffset :: !(Maybe S.SQLExp)
|
||||
} deriving (Show, Eq)
|
||||
|
||||
noTableArgs :: TableArgs
|
||||
noTableArgs = TableArgs Nothing Nothing Nothing Nothing
|
||||
|
||||
data PGColFld
|
||||
= PCFCol !PGCol
|
||||
| PCFExp !T.Text
|
||||
deriving (Show, Eq)
|
||||
|
||||
type ColFlds = [(T.Text, PGColFld)]
|
||||
|
||||
data AggFld
|
||||
= AFCount
|
||||
| AFSum !ColFlds
|
||||
| AFAvg !ColFlds
|
||||
| AFMax !ColFlds
|
||||
| AFMin !ColFlds
|
||||
| AFExp !T.Text
|
||||
deriving (Show, Eq)
|
||||
|
||||
type AggFlds = [(T.Text, AggFld)]
|
||||
|
||||
data TableAggFld
|
||||
= TAFAgg !AggFlds
|
||||
| TAFNodes ![(FieldName, AnnFld)]
|
||||
| TAFExp !T.Text
|
||||
deriving (Show, Eq)
|
||||
|
||||
data AnnSelFields
|
||||
= ASFSimple ![(FieldName, AnnFld)]
|
||||
| ASFWithAgg ![(T.Text, TableAggFld)]
|
||||
deriving (Show, Eq)
|
||||
|
||||
fetchAnnFlds :: AnnSelFields -> [(FieldName, AnnFld)]
|
||||
fetchAnnFlds (ASFSimple flds) = flds
|
||||
fetchAnnFlds (ASFWithAgg aggFlds) =
|
||||
concatMap (fromAggFld . snd) aggFlds
|
||||
where
|
||||
fromAggFld (TAFNodes f) = f
|
||||
fromAggFld _ = []
|
||||
|
||||
data TableFrom
|
||||
= TableFrom
|
||||
{ _tfTable :: !QualifiedTable
|
||||
, _tfFrom :: !(Maybe S.FromItem)
|
||||
} deriving (Show, Eq)
|
||||
|
||||
data TablePerm
|
||||
= TablePerm
|
||||
{ _tpFilter :: !S.BoolExp
|
||||
, _tpLimit :: !(Maybe Int)
|
||||
} deriving (Show, Eq)
|
||||
|
||||
data AnnSel
|
||||
= AnnSel
|
||||
{ _asnFields :: !AnnSelFields
|
||||
, _asnFrom :: !TableFrom
|
||||
, _asnPerm :: !TablePerm
|
||||
, _asnArgs :: !TableArgs
|
||||
} deriving (Show, Eq)
|
||||
|
||||
data BaseNode
|
||||
= BaseNode
|
||||
{ _bnPrefix :: !Iden
|
||||
, _bnFrom :: !S.FromItem
|
||||
, _bnWhere :: !S.BoolExp
|
||||
, _bnOrderBy :: !(Maybe S.OrderByExp)
|
||||
, _bnLimit :: !(Maybe Int)
|
||||
, _bnOffset :: !(Maybe S.SQLExp)
|
||||
|
||||
, _bnExtrs :: !(HM.HashMap S.Alias S.SQLExp)
|
||||
, _bnObjRels :: !(HM.HashMap RelName RelNode)
|
||||
, _bnArrRels :: !(HM.HashMap S.Alias RelNode)
|
||||
|
||||
} deriving (Show, Eq)
|
||||
|
||||
data AggBaseNode
|
||||
= AggBaseNode
|
||||
{ _abnFields :: ![(T.Text, TableAggFld)]
|
||||
, _abnNode :: !BaseNode
|
||||
} deriving (Show, Eq)
|
||||
|
||||
data AnnNode
|
||||
= ANSimple !BaseNode
|
||||
| ANWithAgg !AggBaseNode
|
||||
deriving (Show, Eq)
|
||||
|
||||
data AnnNodeToSelOpts
|
||||
= AnnNodeToSelOpts
|
||||
{ _antsSingleObj :: !Bool
|
||||
, _antsIsObjRel :: !Bool
|
||||
} deriving (Show, Eq)
|
||||
|
||||
objRelOpts :: AnnNodeToSelOpts
|
||||
objRelOpts = AnnNodeToSelOpts False True
|
||||
|
||||
arrRelOpts :: AnnNodeToSelOpts
|
||||
arrRelOpts = AnnNodeToSelOpts False False
|
||||
|
||||
txtToAlias :: Text -> S.Alias
|
||||
txtToAlias = S.Alias . Iden
|
||||
|
||||
aggFldToExp :: Iden -> AggFlds -> S.SQLExp
|
||||
aggFldToExp pfx aggFlds = jsonRow
|
||||
where
|
||||
jsonRow = S.applyJsonBuildObj (concatMap aggToFlds aggFlds)
|
||||
withAls fldName sqlExp = [S.SELit fldName, sqlExp]
|
||||
aggToFlds (t, fld) = withAls t $ case fld of
|
||||
AFCount -> S.SEUnsafe "count(*)"
|
||||
AFSum sumFlds -> colFldsToObj "sum" sumFlds
|
||||
AFAvg avgFlds -> colFldsToObj "avg" avgFlds
|
||||
AFMax maxFlds -> colFldsToObj "max" maxFlds
|
||||
AFMin minFlds -> colFldsToObj "min" minFlds
|
||||
AFExp e -> S.SELit e
|
||||
|
||||
colFldsToObj op flds =
|
||||
S.applyJsonBuildObj $ concatMap (colFldsToExtr op) flds
|
||||
|
||||
colFldsToExtr op (t, PCFCol col) =
|
||||
[ S.SELit t
|
||||
, S.SEFnApp op [S.SEIden $ mkBaseTableColAls pfx col] Nothing
|
||||
]
|
||||
colFldsToExtr _ (t, PCFExp e) =
|
||||
[ S.SELit t , S.SELit e]
|
||||
|
||||
asSingleRow :: S.Alias -> S.FromItem -> S.Select
|
||||
asSingleRow col fromItem =
|
||||
S.mkSelect
|
||||
{ S.selExtr = [S.Extractor extr $ Just col]
|
||||
, S.selFrom = Just $ S.FromExp [fromItem]
|
||||
}
|
||||
where
|
||||
extr = S.SEFnApp "coalesce" [jsonAgg, S.SELit "null"] Nothing
|
||||
jsonAgg = S.SEOpApp (S.SQLOp "->")
|
||||
[ S.SEFnApp "json_agg" [S.SEIden $ toIden col] Nothing
|
||||
, S.SEUnsafe "0"
|
||||
]
|
||||
|
||||
annNodeToSel
|
||||
:: AnnNodeToSelOpts -> S.BoolExp -> S.Alias -> AnnNode -> S.Select
|
||||
annNodeToSel opts joinCond als = \case
|
||||
ANSimple bn -> bool (asJsonAggSel bn) (bnToSel bn) isObjRel
|
||||
ANWithAgg (AggBaseNode flds bn) ->
|
||||
let pfx = _bnPrefix bn
|
||||
baseSelFrom = S.mkSelFromItem (bnToSel bn) (mkAliasFromBN bn)
|
||||
ordBy = _bnOrderBy bn
|
||||
in S.mkSelect
|
||||
{ S.selExtr = [ flip S.Extractor (Just als) $
|
||||
S.applyJsonBuildObj $
|
||||
concatMap (selFldToExtr pfx ordBy) flds
|
||||
]
|
||||
, S.selFrom = Just $ S.FromExp [baseSelFrom]
|
||||
}
|
||||
where
|
||||
AnnNodeToSelOpts singleObj isObjRel = opts
|
||||
bnToSel = baseNodeToSel joinCond
|
||||
mkAliasFromBN = S.Alias . _bnPrefix
|
||||
asJsonAggSel n =
|
||||
let ordByM = _bnOrderBy n
|
||||
fromItem = S.mkSelFromItem (bnToSel n) $
|
||||
mkAliasFromBN n
|
||||
in bool
|
||||
(withJsonAgg ordByM als fromItem)
|
||||
(asSingleRow als fromItem)
|
||||
singleObj
|
||||
|
||||
selFldToExtr pfx ordBy (t, fld) = (:) (S.SELit t) $ pure $ case fld of
|
||||
TAFAgg aggFlds ->
|
||||
aggFldToExp pfx aggFlds
|
||||
TAFNodes _ ->
|
||||
let jsonAgg = S.SEFnApp "json_agg" [S.SEIden $ Iden t] ordBy
|
||||
in S.SEFnApp "coalesce" [jsonAgg, S.SELit "[]"] Nothing
|
||||
TAFExp e ->
|
||||
-- bool_or to force aggregation
|
||||
S.SEFnApp "coalesce"
|
||||
[ S.SELit e , S.SEUnsafe "bool_or('true')::text"] Nothing
|
||||
|
||||
getAliasFromAnnNode :: AnnNode -> S.Alias
|
||||
getAliasFromAnnNode = \case
|
||||
ANSimple bn -> S.Alias $ _bnPrefix bn
|
||||
ANWithAgg abn -> S.Alias $ _bnPrefix $ _abnNode abn
|
||||
|
||||
-- array relationships are not grouped, so have to be prefixed by
|
||||
-- parent's alias
|
||||
mkUniqArrRelAls :: FieldName -> FieldName -> Iden
|
||||
mkUniqArrRelAls parAls relAls =
|
||||
Iden $
|
||||
getFieldNameTxt parAls <> "." <> getFieldNameTxt relAls
|
||||
|
||||
mkArrRelTableAls :: Iden -> FieldName -> FieldName -> Iden
|
||||
mkArrRelTableAls pfx parAls relAls =
|
||||
pfx <> Iden ".ar." <> uniqArrRelAls
|
||||
where
|
||||
uniqArrRelAls = mkUniqArrRelAls parAls relAls
|
||||
|
||||
mkObjRelTableAls :: Iden -> RelName -> Iden
|
||||
mkObjRelTableAls pfx relName =
|
||||
pfx <> Iden ".or." <> toIden relName
|
||||
|
||||
mkBaseTableAls :: Iden -> Iden
|
||||
mkBaseTableAls pfx =
|
||||
pfx <> Iden ".base"
|
||||
|
||||
mkBaseTableColAls :: Iden -> PGCol -> Iden
|
||||
mkBaseTableColAls pfx pgCol =
|
||||
pfx <> Iden ".pg." <> toIden pgCol
|
||||
|
||||
-- posttgres ignores anything beyond 63 chars for an iden
|
||||
-- in this case, we'll need to use json_build_object function
|
||||
-- json_build_object is slower than row_to_json hence it is only
|
||||
-- used when needed
|
||||
buildJsonObject
|
||||
:: Iden -> FieldName
|
||||
-> [(FieldName, AnnFld)] -> (S.Alias, S.SQLExp)
|
||||
buildJsonObject pfx parAls flds =
|
||||
if any ( (> 63) . T.length . getFieldNameTxt . fst ) flds
|
||||
then withJsonBuildObj pfx parAls flds
|
||||
else withRowToJSON pfx parAls flds
|
||||
|
||||
-- uses row_to_json to build a json object
|
||||
withRowToJSON
|
||||
:: Iden -> FieldName
|
||||
-> [(FieldName, AnnFld)] -> (S.Alias, S.SQLExp)
|
||||
withRowToJSON pfx parAls flds =
|
||||
(S.toAlias parAls, jsonRow)
|
||||
where
|
||||
withAls fldName sqlExp =
|
||||
S.Extractor sqlExp $ Just $ S.toAlias fldName
|
||||
jsonRow = S.applyRowToJson (map toFldExtr flds)
|
||||
toFldExtr (fldAls, fld) = withAls fldAls $ case fld of
|
||||
FCol col -> toJSONableExp (pgiType col) $
|
||||
S.mkQIdenExp (mkBaseTableAls pfx) $ pgiName col
|
||||
FExp e -> S.SELit e
|
||||
FRel annRel ->
|
||||
let qual = case arType annRel of
|
||||
ObjRel -> mkObjRelTableAls pfx $ arName annRel
|
||||
ArrRel -> mkArrRelTableAls pfx parAls fldAls
|
||||
in S.mkQIdenExp qual fldAls
|
||||
|
||||
-- uses json_build_object to build a json object
|
||||
withJsonBuildObj
|
||||
:: Iden -> FieldName
|
||||
-> [(FieldName, AnnFld)] -> (S.Alias, S.SQLExp)
|
||||
withJsonBuildObj pfx parAls flds =
|
||||
(S.toAlias parAls, jsonRow)
|
||||
where
|
||||
withAls fldName sqlExp =
|
||||
[S.SELit $ getFieldNameTxt fldName, sqlExp]
|
||||
|
||||
jsonRow = S.applyJsonBuildObj (concatMap toFldExtr flds)
|
||||
|
||||
toFldExtr (fldAls, fld) = withAls fldAls $ case fld of
|
||||
FCol col -> toJSONableExp (pgiType col) $
|
||||
S.mkQIdenExp (mkBaseTableAls pfx) $ pgiName col
|
||||
FExp e -> S.SELit e
|
||||
FRel annRel ->
|
||||
let qual = case arType annRel of
|
||||
ObjRel -> mkObjRelTableAls pfx $ arName annRel
|
||||
ArrRel -> mkArrRelTableAls pfx parAls fldAls
|
||||
in S.mkQIdenExp qual fldAls
|
||||
|
||||
processAnnOrderByItem
|
||||
:: Iden
|
||||
-> AnnOrderByItem
|
||||
-- the extractors which will select the needed columns
|
||||
-> ( (S.Alias, S.SQLExp)
|
||||
-- the sql order by item that is attached to the final select
|
||||
, S.OrderByItem
|
||||
-- optionally we may have to add an obj rel node
|
||||
, Maybe (RelName, RelNode)
|
||||
)
|
||||
processAnnOrderByItem pfx (OrderByItemG obTyM annObCol obNullsM) =
|
||||
( (obColAls, obColExp)
|
||||
, sqlOrdByItem
|
||||
, relNodeM
|
||||
)
|
||||
where
|
||||
((obColAls, obColExp), relNodeM) = processAnnOrderByCol pfx annObCol
|
||||
|
||||
sqlOrdByItem =
|
||||
S.OrderByItem (S.SEIden $ toIden obColAls) obTyM obNullsM
|
||||
|
||||
processAnnOrderByCol
|
||||
:: Iden
|
||||
-> AnnObCol
|
||||
-- the extractors which will select the needed columns
|
||||
-> ( (S.Alias, S.SQLExp)
|
||||
-- optionally we may have to add an obj rel node
|
||||
, Maybe (RelName, RelNode)
|
||||
)
|
||||
processAnnOrderByCol pfx = \case
|
||||
AOCPG colInfo ->
|
||||
let
|
||||
qualCol = S.mkQIdenExp (mkBaseTableAls pfx) (toIden $ pgiName colInfo)
|
||||
obColAls = mkBaseTableColAls pfx $ pgiName colInfo
|
||||
in ( (S.Alias obColAls, qualCol)
|
||||
, Nothing
|
||||
)
|
||||
-- "pfx.or.relname"."pfx.ob.or.relname.rest" AS "pfx.ob.or.relname.rest"
|
||||
AOCRel (RelInfo rn _ colMapping relTab _ _) relFltr rest ->
|
||||
let relPfx = mkObjRelTableAls pfx rn
|
||||
((nesAls, nesCol), nesNodeM) = processAnnOrderByCol relPfx rest
|
||||
qualCol = S.mkQIdenExp relPfx nesAls
|
||||
relBaseNode = ANSimple $
|
||||
BaseNode relPfx (S.FISimple relTab Nothing) relFltr
|
||||
Nothing Nothing Nothing
|
||||
(HM.singleton nesAls nesCol)
|
||||
(maybe HM.empty (uncurry HM.singleton) nesNodeM)
|
||||
HM.empty
|
||||
relNode = RelNode rn (fromRel rn) colMapping relBaseNode
|
||||
in ( (nesAls, qualCol)
|
||||
, Just (rn, relNode)
|
||||
)
|
||||
|
||||
mkEmptyBaseNode :: Iden -> TableFrom -> BaseNode
|
||||
mkEmptyBaseNode pfx tableFrom =
|
||||
BaseNode pfx fromItem (S.BELit True) Nothing Nothing Nothing
|
||||
selOne HM.empty HM.empty
|
||||
where
|
||||
selOne = HM.singleton (S.Alias $ pfx <> Iden "__one") (S.SEUnsafe "1")
|
||||
TableFrom tn fromItemM = tableFrom
|
||||
fromItem = fromMaybe (S.FISimple tn Nothing) fromItemM
|
||||
|
||||
mkBaseNode
|
||||
:: Iden
|
||||
-> FieldName
|
||||
-> TableAggFld
|
||||
-> TableFrom
|
||||
-> TablePerm
|
||||
-> TableArgs
|
||||
-> BaseNode
|
||||
mkBaseNode pfx fldAls annSelFlds tableFrom tablePerm tableArgs =
|
||||
BaseNode pfx fromItem finalWhere ordByExpM finalLimit offsetM
|
||||
allExtrs allObjsWithOb allArrs
|
||||
where
|
||||
TableFrom tn fromItemM = tableFrom
|
||||
TablePerm fltr permLimitM = tablePerm
|
||||
TableArgs whereM orderByM limitM offsetM = tableArgs
|
||||
(allExtrs, allObjsWithOb, allArrs) = case annSelFlds of
|
||||
TAFNodes flds ->
|
||||
let selExtr = buildJsonObject pfx fldAls flds
|
||||
-- all the relationships
|
||||
(allObjs, allArrRels) =
|
||||
foldl' addRel (HM.empty, HM.empty) $
|
||||
mapMaybe (\(als, f) -> (als,) <$> getAnnRel f) flds
|
||||
allObjRelsWithOb =
|
||||
foldl' (\objs (rn, relNode) -> HM.insertWith mergeRelNodes rn relNode objs)
|
||||
allObjs $ catMaybes $ maybe [] _3 procOrdByM
|
||||
in ( HM.fromList $ selExtr:obExtrs
|
||||
, allObjRelsWithOb
|
||||
, allArrRels
|
||||
)
|
||||
TAFAgg aggFlds ->
|
||||
let extrs = concatMap (fetchExtrFromAggFld . snd) aggFlds
|
||||
in ( HM.fromList $ extrs <> obExtrs
|
||||
, HM.empty
|
||||
, HM.empty
|
||||
)
|
||||
TAFExp _ -> (HM.fromList obExtrs, HM.empty, HM.empty)
|
||||
|
||||
fetchExtrFromAggFld AFCount = []
|
||||
fetchExtrFromAggFld (AFSum sumFlds) = colFldsToExps sumFlds
|
||||
fetchExtrFromAggFld (AFAvg avgFlds) = colFldsToExps avgFlds
|
||||
fetchExtrFromAggFld (AFMax maxFlds) = colFldsToExps maxFlds
|
||||
fetchExtrFromAggFld (AFMin minFlds) = colFldsToExps minFlds
|
||||
fetchExtrFromAggFld (AFExp _) = []
|
||||
|
||||
colFldsToExps = mapMaybe (mkColExp . snd)
|
||||
|
||||
mkColExp (PCFCol c) =
|
||||
let qualCol = S.mkQIdenExp (mkBaseTableAls pfx) (toIden c)
|
||||
colAls = mkBaseTableColAls pfx c
|
||||
in Just (S.Alias colAls, qualCol)
|
||||
mkColExp _ = Nothing
|
||||
|
||||
finalWhere = maybe fltr (S.BEBin S.AndOp fltr . cBoolExp) whereM
|
||||
finalLimit = applyPermLimit permLimitM limitM
|
||||
|
||||
fromItem = fromMaybe (S.FISimple tn Nothing) fromItemM
|
||||
|
||||
_1 (a, _, _) = a
|
||||
_2 (_, b, _) = b
|
||||
_3 (_, _, c) = c
|
||||
|
||||
procOrdByM = unzip3 . map (processAnnOrderByItem pfx) . toList <$> orderByM
|
||||
ordByExpM = S.OrderByExp . _2 <$> procOrdByM
|
||||
|
||||
-- the columns needed for orderby
|
||||
obExtrs = maybe [] _1 procOrdByM
|
||||
|
||||
mkRelPfx rTy rn relAls = case rTy of
|
||||
ObjRel -> mkObjRelTableAls pfx rn
|
||||
ArrRel -> mkArrRelTableAls pfx fldAls relAls
|
||||
|
||||
-- process a relationship
|
||||
addRel (objs, arrs) (relAls, annRel) =
|
||||
let relName = arName annRel
|
||||
relNodePfx = mkRelPfx (arType annRel) relName relAls
|
||||
relNode = mkRelNode relNodePfx (relAls, annRel)
|
||||
in case arType annRel of
|
||||
-- in case of object relationships, we merge
|
||||
ObjRel ->
|
||||
(HM.insertWith mergeRelNodes relName relNode objs, arrs)
|
||||
ArrRel ->
|
||||
let arrRelTableAls = S.Alias $ mkUniqArrRelAls fldAls relAls
|
||||
in (objs, HM.insert arrRelTableAls relNode arrs)
|
||||
|
||||
getAnnRel = \case
|
||||
FCol _ -> Nothing
|
||||
FExp _ -> Nothing
|
||||
FRel ar -> Just ar
|
||||
|
||||
annSelToAnnNode :: Iden -> FieldName -> AnnSel -> AnnNode
|
||||
annSelToAnnNode pfx fldAls annSel =
|
||||
case selFlds of
|
||||
ASFSimple flds -> ANSimple $ mkBaseNode pfx fldAls (TAFNodes flds)
|
||||
tabFrm tabPerm tabArgs
|
||||
ASFWithAgg aggFlds ->
|
||||
let allBNs = map mkAggBaseNode aggFlds
|
||||
emptyBN = mkEmptyBaseNode pfx tabFrm
|
||||
mergedBN = foldr mergeBaseNodes emptyBN allBNs
|
||||
in ANWithAgg $ AggBaseNode aggFlds mergedBN
|
||||
where
|
||||
AnnSel selFlds tabFrm tabPerm tabArgs = annSel
|
||||
mkAggBaseNode (t, selFld) =
|
||||
mkBaseNode pfx (FieldName t) selFld tabFrm tabPerm tabArgs
|
||||
|
||||
mergeBaseNodes :: BaseNode -> BaseNode -> BaseNode
|
||||
mergeBaseNodes lNodeDet rNodeDet =
|
||||
BaseNode pfx f whr ordBy limit offset
|
||||
(HM.union lExtrs rExtrs)
|
||||
(HM.unionWith mergeRelNodes lObjs rObjs)
|
||||
(HM.union lArrs rArrs)
|
||||
where
|
||||
(BaseNode pfx f whr ordBy limit offset lExtrs lObjs lArrs) = lNodeDet
|
||||
(BaseNode _ _ _ _ _ _ rExtrs rObjs rArrs) = rNodeDet
|
||||
|
||||
mergeAnnNodes :: AnnNode -> AnnNode -> AnnNode
|
||||
mergeAnnNodes lNode rNode =
|
||||
case (lNode, rNode) of
|
||||
(ANSimple lbn, ANSimple rbn) -> ANSimple $ mergeBaseNodes lbn rbn
|
||||
(ANSimple lbn, ANWithAgg (AggBaseNode _ rbn)) ->
|
||||
ANSimple $ mergeBaseNodes lbn rbn
|
||||
(ANWithAgg (AggBaseNode flds lbn), ANSimple rbn) ->
|
||||
ANWithAgg $ AggBaseNode flds $ mergeBaseNodes lbn rbn
|
||||
|
||||
(ANWithAgg (AggBaseNode lflds lbn), ANWithAgg (AggBaseNode rflds rbn)) ->
|
||||
ANWithAgg $ AggBaseNode (lflds <> rflds) $ mergeBaseNodes lbn rbn
|
||||
|
||||
|
||||
-- should only be used to merge obj rel nodes
|
||||
mergeRelNodes :: RelNode -> RelNode -> RelNode
|
||||
mergeRelNodes lNode rNode =
|
||||
RelNode rn rAls rMapn $ mergeAnnNodes lNodeDet rNodeDet
|
||||
where
|
||||
(RelNode rn rAls rMapn lNodeDet) = lNode
|
||||
(RelNode _ _ _ rNodeDet) = rNode
|
||||
|
||||
data RelNode
|
||||
= RelNode
|
||||
{ _rnRelName :: !RelName
|
||||
, _rnRelAlias :: !FieldName
|
||||
, _rnRelMapping :: ![(PGCol, PGCol)]
|
||||
, _rnNodeDet :: !AnnNode
|
||||
} deriving (Show, Eq)
|
||||
|
||||
mkRelNode :: Iden -> (FieldName, AnnRel) -> RelNode
|
||||
mkRelNode pfx (relAls, AnnRel rn _ rMapn rAnnSel) =
|
||||
RelNode rn relAls rMapn $ annSelToAnnNode pfx relAls rAnnSel
|
||||
|
||||
withJsonAgg :: Maybe S.OrderByExp -> S.Alias -> S.FromItem -> S.Select
|
||||
withJsonAgg orderByM col fromItem =
|
||||
S.mkSelect
|
||||
{ S.selExtr = [S.Extractor extr $ Just col]
|
||||
, S.selFrom = Just $ S.FromExp [fromItem]
|
||||
}
|
||||
where
|
||||
extr = S.SEFnApp "coalesce" [jsonAgg, S.SELit "[]"] Nothing
|
||||
jsonAgg = S.SEFnApp "json_agg" [S.SEIden $ toIden col] orderByM
|
||||
|
||||
baseNodeToSel :: S.BoolExp -> BaseNode -> S.Select
|
||||
baseNodeToSel joinCond (BaseNode pfx fromItem whr ordByM limitM offsetM extrs objRels arrRels) =
|
||||
S.mkSelect
|
||||
{ S.selExtr = [S.Extractor e $ Just a | (a, e) <- HM.toList extrs]
|
||||
, S.selFrom = Just $ S.FromExp [joinedFrom]
|
||||
, S.selOrderBy = ordByM
|
||||
, S.selLimit = S.LimitExp . S.intToSQLExp <$> limitM
|
||||
, S.selOffset = S.OffsetExp <$> offsetM
|
||||
}
|
||||
where
|
||||
-- this is the table which is aliased as "pfx.base"
|
||||
baseSel = S.mkSelect
|
||||
{ S.selExtr = [S.Extractor S.SEStar Nothing]
|
||||
, S.selFrom = Just $ S.FromExp [fromItem]
|
||||
, S.selWhere = Just $ injectJoinCond joinCond whr
|
||||
}
|
||||
baseSelAls = S.Alias $ mkBaseTableAls pfx
|
||||
baseFromItem = S.FISelect (S.Lateral False) baseSel baseSelAls
|
||||
|
||||
-- function to create a joined from item from two from items
|
||||
leftOuterJoin current new =
|
||||
S.FIJoin $ S.JoinExpr current S.LeftOuter new $
|
||||
S.JoinOn $ S.BELit True
|
||||
|
||||
-- this is the from eexp for the final select
|
||||
joinedFrom :: S.FromItem
|
||||
joinedFrom = foldl' leftOuterJoin baseFromItem $
|
||||
map objRelToFromItem (HM.elems objRels) <>
|
||||
map arrRelToFromItem (HM.elems arrRels)
|
||||
|
||||
relNodeToSelect :: AnnNodeToSelOpts -> RelNode -> (S.Select, S.Alias)
|
||||
relNodeToSelect opts (RelNode _ fldName relMapn relBaseNode) =
|
||||
let als = S.Alias $ toIden fldName
|
||||
in ( annNodeToSel opts (mkJoinCond baseSelAls relMapn) als relBaseNode
|
||||
, getAliasFromAnnNode relBaseNode
|
||||
)
|
||||
|
||||
objRelToFromItem :: RelNode -> S.FromItem
|
||||
objRelToFromItem =
|
||||
uncurry S.mkLateralFromItem . relNodeToSelect objRelOpts
|
||||
|
||||
arrRelToFromItem :: RelNode -> S.FromItem
|
||||
arrRelToFromItem relNode =
|
||||
let (sel, als) = relNodeToSelect arrRelOpts relNode
|
||||
in S.mkLateralFromItem sel als
|
||||
|
||||
mkJoinCond :: S.Alias -> [(PGCol, PGCol)] -> S.BoolExp
|
||||
mkJoinCond baseTableAls colMapn =
|
||||
foldl' (S.BEBin S.AndOp) (S.BELit True) $ flip map colMapn $
|
||||
\(lCol, rCol) ->
|
||||
S.BECompare S.SEQ (S.mkQIdenExp baseTableAls lCol) (S.mkSIdenExp rCol)
|
||||
import qualified Database.PG.Query as Q
|
||||
import qualified Hasura.SQL.DML as S
|
||||
|
||||
convSelCol :: (P1C m)
|
||||
=> FieldInfoMap
|
||||
@ -687,21 +108,6 @@ resolveStar fim spi (SelectG selCols mWh mOb mLt mOf) = do
|
||||
equals (ECRel x _ _) (ECRel y _ _) = x == y
|
||||
equals _ _ = False
|
||||
|
||||
data AnnObCol
|
||||
= AOCPG !PGColInfo
|
||||
| AOCRel !RelInfo !S.BoolExp !AnnObCol
|
||||
deriving (Show, Eq)
|
||||
|
||||
type AnnOrderByItem = OrderByItemG AnnObCol
|
||||
|
||||
partAnnFlds
|
||||
:: [AnnFld] -> ([(PGCol, PGColType)], [AnnRel])
|
||||
partAnnFlds flds =
|
||||
partitionEithers $ catMaybes $ flip map flds $ \case
|
||||
FCol c -> Just $ Left (pgiName c, pgiType c)
|
||||
FRel r -> Just $ Right r
|
||||
FExp _ -> Nothing
|
||||
|
||||
convOrderByElem
|
||||
:: (P1C m)
|
||||
=> (FieldInfoMap, SelPermInfo)
|
||||
@ -741,19 +147,6 @@ convOrderByElem (flds, spi) = \case
|
||||
AOCRel relInfo (spiFilter relSpi) <$>
|
||||
convOrderByElem (relFim, relSpi) rest
|
||||
|
||||
-- If query limit > permission limit then consider permission limit Else consider query limit
|
||||
applyPermLimit
|
||||
:: Maybe Int -- Permission limit
|
||||
-> Maybe Int -- Query limit
|
||||
-> Maybe Int -- Return SQL exp
|
||||
applyPermLimit mPermLimit mQueryLimit =
|
||||
maybe mQueryLimit compareWithPermLimit mPermLimit
|
||||
where
|
||||
compareWithPermLimit pLimit =
|
||||
maybe (Just pLimit) (compareLimits pLimit) mQueryLimit
|
||||
compareLimits pLimit qLimit = Just $
|
||||
if qLimit > pLimit then pLimit else qLimit
|
||||
|
||||
convSelectQ
|
||||
:: (P1C m)
|
||||
=> FieldInfoMap -- Table information of current table
|
||||
@ -789,10 +182,9 @@ convSelectQ fieldInfoMap selPermInfo selQ prepValBuilder = do
|
||||
withPathK "limit" $ mapM_ onlyPositiveInt mQueryLimit
|
||||
withPathK "offset" $ mapM_ onlyPositiveInt mQueryOffset
|
||||
|
||||
let selFlds = ASFSimple annFlds
|
||||
tabFrom = TableFrom (spiTable selPermInfo) Nothing
|
||||
let tabFrom = TableFrom (spiTable selPermInfo) Nothing
|
||||
tabPerm = TablePerm (spiFilter selPermInfo) mPermLimit
|
||||
return $ AnnSel selFlds tabFrom tabPerm $
|
||||
return $ AnnSelG annFlds tabFrom tabPerm $
|
||||
TableArgs wClause annOrdByM mQueryLimit (S.intToSQLExp <$> mQueryOffset)
|
||||
|
||||
where
|
||||
@ -844,16 +236,19 @@ convExtRel fieldInfoMap relName mAlias selQ prepValBuilder = do
|
||||
, " can't be used"
|
||||
]
|
||||
|
||||
injectJoinCond :: S.BoolExp -- ^ Join condition
|
||||
-> S.BoolExp -- ^ Where condition
|
||||
-> S.WhereFrag -- ^ New where frag
|
||||
injectJoinCond joinCond whereCond =
|
||||
S.WhereFrag $ S.simplifyBoolExp $ S.BEBin S.AndOp joinCond whereCond
|
||||
partAnnFlds
|
||||
:: [AnnFld] -> ([(PGCol, PGColType)], [AnnRel])
|
||||
partAnnFlds flds =
|
||||
partitionEithers $ catMaybes $ flip map flds $ \case
|
||||
FCol c -> Just $ Left (pgiName c, pgiType c)
|
||||
FRel r -> Just $ Right r
|
||||
FAgg _ -> Nothing
|
||||
FExp _ -> Nothing
|
||||
|
||||
getSelectDeps
|
||||
:: AnnSel
|
||||
-> [SchemaDependency]
|
||||
getSelectDeps (AnnSel flds tabFrm _ tableArgs) =
|
||||
getSelectDeps (AnnSelG flds tabFrm _ tableArgs) =
|
||||
mkParentDep tn
|
||||
: fromMaybe [] whereDeps
|
||||
<> colDeps
|
||||
@ -862,7 +257,7 @@ getSelectDeps (AnnSel flds tabFrm _ tableArgs) =
|
||||
where
|
||||
TableFrom tn _ = tabFrm
|
||||
annWc = _taWhere tableArgs
|
||||
(sCols, rCols) = partAnnFlds $ map snd $ fetchAnnFlds flds
|
||||
(sCols, rCols) = partAnnFlds $ map snd flds
|
||||
colDeps = map (mkColDep "untyped" tn . fst) sCols
|
||||
relDeps = map (mkRelDep . arName) rCols
|
||||
nestedDeps = concatMap (getSelectDeps . arAnnSel) rCols
|
||||
@ -882,13 +277,27 @@ convSelectQuery prepArgBuilder (DMLQuery qt selQ) = do
|
||||
validateHeaders $ spiRequiredHeaders selPermInfo
|
||||
convSelectQ (tiFieldInfoMap tabInfo) selPermInfo extSelQ prepArgBuilder
|
||||
|
||||
mkAggSelect :: AnnAggSel -> S.Select
|
||||
mkAggSelect annAggSel =
|
||||
prefixNumToAliases $ aggNodeToSelect bn extr $ S.BELit True
|
||||
where
|
||||
aggSel = AggSel [] annAggSel
|
||||
AggNode _ extr bn =
|
||||
aggSelToAggNode (Iden "root") (FieldName "root") aggSel
|
||||
|
||||
selectAggP2 :: (AnnAggSel, DS.Seq Q.PrepArg) -> Q.TxE QErr RespBody
|
||||
selectAggP2 (sel, p) =
|
||||
runIdentity . Q.getRow
|
||||
<$> Q.rawQE dmlTxErrorHandler (Q.fromBuilder selectSQL) (toList p) True
|
||||
where
|
||||
selectSQL = toSQL $ mkAggSelect sel
|
||||
|
||||
mkSQLSelect :: Bool -> AnnSel -> S.Select
|
||||
mkSQLSelect isSingleObject annSel =
|
||||
prefixNumToAliases $ annNodeToSel selOpts (S.BELit True)
|
||||
rootFldAls $ annSelToAnnNode (toIden rootFldName)
|
||||
prefixNumToAliases $ asJsonAggSel isSingleObject rootFldAls (S.BELit True)
|
||||
$ annSelToBaseNode (toIden rootFldName)
|
||||
rootFldName annSel
|
||||
where
|
||||
selOpts = AnnNodeToSelOpts isSingleObject False
|
||||
rootFldName = FieldName "root"
|
||||
rootFldAls = S.Alias $ toIden rootFldName
|
||||
|
||||
|
||||
611
server/src-lib/Hasura/RQL/DML/Select/Internal.hs
Normal file
611
server/src-lib/Hasura/RQL/DML/Select/Internal.hs
Normal file
@ -0,0 +1,611 @@
|
||||
{-# LANGUAGE DeriveLift #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
module Hasura.RQL.DML.Select.Internal where
|
||||
|
||||
import Data.Aeson.Types
|
||||
import Instances.TH.Lift ()
|
||||
import Language.Haskell.TH.Syntax (Lift)
|
||||
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import qualified Data.Text as T
|
||||
|
||||
import Hasura.Prelude
|
||||
import Hasura.RQL.DML.Internal
|
||||
import Hasura.RQL.GBoolExp
|
||||
import Hasura.RQL.Types
|
||||
import Hasura.SQL.Types
|
||||
|
||||
import qualified Hasura.SQL.DML as S
|
||||
|
||||
-- Conversion of SelectQ happens in 2 Stages.
|
||||
-- Stage 1 : Convert input query into an annotated AST
|
||||
-- Stage 2 : Convert annotated AST to SQL Select
|
||||
|
||||
type SelectQExt = SelectG ExtCol BoolExp Int
|
||||
-- Columns in RQL
|
||||
data ExtCol
|
||||
= ECSimple !PGCol
|
||||
| ECRel !RelName !(Maybe RelName) !SelectQExt
|
||||
deriving (Show, Eq, Lift)
|
||||
|
||||
instance ToJSON ExtCol where
|
||||
toJSON (ECSimple s) = toJSON s
|
||||
toJSON (ECRel rn mrn selq) =
|
||||
object $ [ "name" .= rn
|
||||
, "alias" .= mrn
|
||||
] ++ selectGToPairs selq
|
||||
|
||||
instance FromJSON ExtCol where
|
||||
parseJSON v@(Object o) =
|
||||
ECRel
|
||||
<$> o .: "name"
|
||||
<*> o .:? "alias"
|
||||
<*> parseJSON v
|
||||
parseJSON (String s) =
|
||||
return $ ECSimple $ PGCol s
|
||||
parseJSON _ =
|
||||
fail $ mconcat
|
||||
[ "A column should either be a string or an "
|
||||
, "object (relationship)"
|
||||
]
|
||||
|
||||
data AnnObCol
|
||||
= AOCPG !PGColInfo
|
||||
| AOCRel !RelInfo !S.BoolExp !AnnObCol
|
||||
deriving (Show, Eq)
|
||||
|
||||
type AnnOrderByItem = OrderByItemG AnnObCol
|
||||
|
||||
data AnnRel
|
||||
= AnnRel
|
||||
{ arName :: !RelName -- Relationship name
|
||||
, arType :: !RelType -- Relationship type (ObjRel, ArrRel)
|
||||
, arMapping :: ![(PGCol, PGCol)] -- Column of the left table to join with
|
||||
, arAnnSel :: !AnnSel -- Current table. Almost ~ to SQL Select
|
||||
} deriving (Show, Eq)
|
||||
|
||||
type AnnAggSel = AnnSelG [(T.Text, TableAggFld)]
|
||||
|
||||
data AggSel
|
||||
= AggSel
|
||||
{ agColMapping :: ![(PGCol, PGCol)]
|
||||
, agAnnSel :: !AnnAggSel
|
||||
} deriving (Show, Eq)
|
||||
|
||||
data AnnFld
|
||||
= FCol !PGColInfo
|
||||
| FExp !T.Text
|
||||
| FRel !AnnRel
|
||||
| FAgg !AggSel
|
||||
deriving (Show, Eq)
|
||||
|
||||
data TableArgs
|
||||
= TableArgs
|
||||
{ _taWhere :: !(Maybe (GBoolExp AnnSQLBoolExp))
|
||||
, _taOrderBy :: !(Maybe (NE.NonEmpty AnnOrderByItem))
|
||||
, _taLimit :: !(Maybe Int)
|
||||
, _taOffset :: !(Maybe S.SQLExp)
|
||||
} deriving (Show, Eq)
|
||||
|
||||
noTableArgs :: TableArgs
|
||||
noTableArgs = TableArgs Nothing Nothing Nothing Nothing
|
||||
|
||||
data PGColFld
|
||||
= PCFCol !PGCol
|
||||
| PCFExp !T.Text
|
||||
deriving (Show, Eq)
|
||||
|
||||
type ColFlds = [(T.Text, PGColFld)]
|
||||
|
||||
data AggFld
|
||||
= AFCount
|
||||
| AFSum !ColFlds
|
||||
| AFAvg !ColFlds
|
||||
| AFMax !ColFlds
|
||||
| AFMin !ColFlds
|
||||
| AFExp !T.Text
|
||||
deriving (Show, Eq)
|
||||
|
||||
type AggFlds = [(T.Text, AggFld)]
|
||||
|
||||
data TableAggFld
|
||||
= TAFAgg !AggFlds
|
||||
| TAFNodes ![(FieldName, AnnFld)]
|
||||
| TAFExp !T.Text
|
||||
deriving (Show, Eq)
|
||||
|
||||
data TableFrom
|
||||
= TableFrom
|
||||
{ _tfTable :: !QualifiedTable
|
||||
, _tfFrom :: !(Maybe S.FromItem)
|
||||
} deriving (Show, Eq)
|
||||
|
||||
data TablePerm
|
||||
= TablePerm
|
||||
{ _tpFilter :: !S.BoolExp
|
||||
, _tpLimit :: !(Maybe Int)
|
||||
} deriving (Show, Eq)
|
||||
|
||||
data AnnSelG a
|
||||
= AnnSelG
|
||||
{ _asnFields :: !a
|
||||
, _asnFrom :: !TableFrom
|
||||
, _asnPerm :: !TablePerm
|
||||
, _asnArgs :: !TableArgs
|
||||
} deriving (Show, Eq)
|
||||
|
||||
type AnnSel = AnnSelG [(FieldName, AnnFld)]
|
||||
|
||||
data BaseNode
|
||||
= BaseNode
|
||||
{ _bnPrefix :: !Iden
|
||||
, _bnFrom :: !S.FromItem
|
||||
, _bnWhere :: !S.BoolExp
|
||||
, _bnOrderBy :: !(Maybe S.OrderByExp)
|
||||
, _bnLimit :: !(Maybe Int)
|
||||
, _bnOffset :: !(Maybe S.SQLExp)
|
||||
|
||||
, _bnExtrs :: !(HM.HashMap S.Alias S.SQLExp)
|
||||
, _bnObjRels :: !(HM.HashMap RelName RelNode)
|
||||
, _bnArrRels :: !(HM.HashMap S.Alias RelNode)
|
||||
, _bnAggs :: !(HM.HashMap S.Alias AggNode)
|
||||
|
||||
} deriving (Show, Eq)
|
||||
|
||||
txtToAlias :: Text -> S.Alias
|
||||
txtToAlias = S.Alias . Iden
|
||||
|
||||
aggFldToExp :: Iden -> AggFlds -> S.SQLExp
|
||||
aggFldToExp pfx aggFlds = jsonRow
|
||||
where
|
||||
jsonRow = S.applyJsonBuildObj (concatMap aggToFlds aggFlds)
|
||||
withAls fldName sqlExp = [S.SELit fldName, sqlExp]
|
||||
aggToFlds (t, fld) = withAls t $ case fld of
|
||||
AFCount -> S.SEUnsafe "count(*)"
|
||||
AFSum sumFlds -> colFldsToObj "sum" sumFlds
|
||||
AFAvg avgFlds -> colFldsToObj "avg" avgFlds
|
||||
AFMax maxFlds -> colFldsToObj "max" maxFlds
|
||||
AFMin minFlds -> colFldsToObj "min" minFlds
|
||||
AFExp e -> S.SELit e
|
||||
|
||||
colFldsToObj op flds =
|
||||
S.applyJsonBuildObj $ concatMap (colFldsToExtr op) flds
|
||||
|
||||
colFldsToExtr op (t, PCFCol col) =
|
||||
[ S.SELit t
|
||||
, S.SEFnApp op [S.SEIden $ mkBaseTableColAls pfx col] Nothing
|
||||
]
|
||||
colFldsToExtr _ (t, PCFExp e) =
|
||||
[ S.SELit t , S.SELit e]
|
||||
|
||||
asSingleRow :: S.Alias -> S.FromItem -> S.Select
|
||||
asSingleRow col fromItem =
|
||||
S.mkSelect
|
||||
{ S.selExtr = [S.Extractor extr $ Just col]
|
||||
, S.selFrom = Just $ S.FromExp [fromItem]
|
||||
}
|
||||
where
|
||||
extr = S.SEFnApp "coalesce" [jsonAgg, S.SELit "null"] Nothing
|
||||
jsonAgg = S.SEOpApp (S.SQLOp "->")
|
||||
[ S.SEFnApp "json_agg" [S.SEIden $ toIden col] Nothing
|
||||
, S.SEUnsafe "0"
|
||||
]
|
||||
|
||||
aggNodeToSelect :: BaseNode -> S.Extractor -> S.BoolExp -> S.Select
|
||||
aggNodeToSelect bn extr joinCond =
|
||||
S.mkSelect
|
||||
{ S.selExtr = [extr]
|
||||
, S.selFrom = Just $ S.FromExp [selFrom]
|
||||
}
|
||||
where
|
||||
selFrom = S.mkSelFromItem (baseNodeToSel joinCond bn) $ S.Alias $
|
||||
_bnPrefix bn
|
||||
|
||||
withJsonAgg :: Maybe S.OrderByExp -> S.Alias -> S.FromItem -> S.Select
|
||||
withJsonAgg orderByM col fromItem =
|
||||
S.mkSelect
|
||||
{ S.selExtr = [S.Extractor extr $ Just col]
|
||||
, S.selFrom = Just $ S.FromExp [fromItem]
|
||||
}
|
||||
where
|
||||
extr = S.SEFnApp "coalesce" [jsonAgg, S.SELit "[]"] Nothing
|
||||
jsonAgg = S.SEFnApp "json_agg" [S.SEIden $ toIden col] orderByM
|
||||
|
||||
asJsonAggSel :: Bool -> S.Alias -> S.BoolExp -> BaseNode -> S.Select
|
||||
asJsonAggSel singleObj als joinCond n =
|
||||
let ordByM = _bnOrderBy n
|
||||
fromItem = S.mkSelFromItem (baseNodeToSel joinCond n) $
|
||||
S.Alias $ _bnPrefix n
|
||||
in bool
|
||||
(withJsonAgg ordByM als fromItem)
|
||||
(asSingleRow als fromItem)
|
||||
singleObj
|
||||
|
||||
-- array relationships are not grouped, so have to be prefixed by
|
||||
-- parent's alias
|
||||
mkUniqArrRelAls :: FieldName -> FieldName -> Iden
|
||||
mkUniqArrRelAls parAls relAls =
|
||||
Iden $
|
||||
getFieldNameTxt parAls <> "." <> getFieldNameTxt relAls
|
||||
|
||||
mkArrRelTableAls :: Iden -> FieldName -> FieldName -> Iden
|
||||
mkArrRelTableAls pfx parAls relAls =
|
||||
pfx <> Iden ".ar." <> uniqArrRelAls
|
||||
where
|
||||
uniqArrRelAls = mkUniqArrRelAls parAls relAls
|
||||
|
||||
mkObjRelTableAls :: Iden -> RelName -> Iden
|
||||
mkObjRelTableAls pfx relName =
|
||||
pfx <> Iden ".or." <> toIden relName
|
||||
|
||||
mkAggAls :: Iden -> FieldName -> Iden
|
||||
mkAggAls pfx fldAls =
|
||||
pfx <> Iden ".agg." <> toIden fldAls
|
||||
|
||||
mkBaseTableAls :: Iden -> Iden
|
||||
mkBaseTableAls pfx =
|
||||
pfx <> Iden ".base"
|
||||
|
||||
mkBaseTableColAls :: Iden -> PGCol -> Iden
|
||||
mkBaseTableColAls pfx pgCol =
|
||||
pfx <> Iden ".pg." <> toIden pgCol
|
||||
|
||||
-- posttgres ignores anything beyond 63 chars for an iden
|
||||
-- in this case, we'll need to use json_build_object function
|
||||
-- json_build_object is slower than row_to_json hence it is only
|
||||
-- used when needed
|
||||
buildJsonObject
|
||||
:: Iden -> FieldName
|
||||
-> [(FieldName, AnnFld)] -> (S.Alias, S.SQLExp)
|
||||
buildJsonObject pfx parAls flds =
|
||||
if any ( (> 63) . T.length . getFieldNameTxt . fst ) flds
|
||||
then withJsonBuildObj parAls jsonBuildObjExps
|
||||
else withRowToJSON parAls rowToJsonExtrs
|
||||
where
|
||||
jsonBuildObjExps = concatMap (toSQLFld withAlsExp) flds
|
||||
rowToJsonExtrs = map (toSQLFld withAlsExtr) flds
|
||||
|
||||
withAlsExp fldName sqlExp =
|
||||
[S.SELit $ getFieldNameTxt fldName, sqlExp]
|
||||
withAlsExtr fldName sqlExp =
|
||||
S.Extractor sqlExp $ Just $ S.toAlias fldName
|
||||
|
||||
toSQLFld f (fldAls, fld) = f fldAls $ case fld of
|
||||
FCol col -> toJSONableExp (pgiType col) $
|
||||
S.mkQIdenExp (mkBaseTableAls pfx) $ pgiName col
|
||||
FExp e -> S.SELit e
|
||||
FRel annRel ->
|
||||
let qual = case arType annRel of
|
||||
ObjRel -> mkObjRelTableAls pfx $ arName annRel
|
||||
ArrRel -> mkArrRelTableAls pfx parAls fldAls
|
||||
in S.mkQIdenExp qual fldAls
|
||||
FAgg _ -> S.mkQIdenExp (mkAggAls pfx fldAls) fldAls
|
||||
|
||||
-- uses row_to_json to build a json object
|
||||
withRowToJSON
|
||||
:: FieldName -> [S.Extractor] -> (S.Alias, S.SQLExp)
|
||||
withRowToJSON parAls extrs =
|
||||
(S.toAlias parAls, jsonRow)
|
||||
where
|
||||
jsonRow = S.applyRowToJson extrs
|
||||
|
||||
-- uses json_build_object to build a json object
|
||||
withJsonBuildObj
|
||||
:: FieldName -> [S.SQLExp] -> (S.Alias, S.SQLExp)
|
||||
withJsonBuildObj parAls exps =
|
||||
(S.toAlias parAls, jsonRow)
|
||||
where
|
||||
jsonRow = S.applyJsonBuildObj exps
|
||||
|
||||
processAnnOrderByItem
|
||||
:: Iden
|
||||
-> AnnOrderByItem
|
||||
-- the extractors which will select the needed columns
|
||||
-> ( (S.Alias, S.SQLExp)
|
||||
-- the sql order by item that is attached to the final select
|
||||
, S.OrderByItem
|
||||
-- optionally we may have to add an obj rel node
|
||||
, Maybe (RelName, RelNode)
|
||||
)
|
||||
processAnnOrderByItem pfx (OrderByItemG obTyM annObCol obNullsM) =
|
||||
( (obColAls, obColExp)
|
||||
, sqlOrdByItem
|
||||
, relNodeM
|
||||
)
|
||||
where
|
||||
((obColAls, obColExp), relNodeM) = processAnnOrderByCol pfx annObCol
|
||||
|
||||
sqlOrdByItem =
|
||||
S.OrderByItem (S.SEIden $ toIden obColAls) obTyM obNullsM
|
||||
|
||||
processAnnOrderByCol
|
||||
:: Iden
|
||||
-> AnnObCol
|
||||
-- the extractors which will select the needed columns
|
||||
-> ( (S.Alias, S.SQLExp)
|
||||
-- optionally we may have to add an obj rel node
|
||||
, Maybe (RelName, RelNode)
|
||||
)
|
||||
processAnnOrderByCol pfx = \case
|
||||
AOCPG colInfo ->
|
||||
let
|
||||
qualCol = S.mkQIdenExp (mkBaseTableAls pfx) (toIden $ pgiName colInfo)
|
||||
obColAls = mkBaseTableColAls pfx $ pgiName colInfo
|
||||
in ( (S.Alias obColAls, qualCol)
|
||||
, Nothing
|
||||
)
|
||||
-- "pfx.or.relname"."pfx.ob.or.relname.rest" AS "pfx.ob.or.relname.rest"
|
||||
AOCRel (RelInfo rn _ colMapping relTab _ _) relFltr rest ->
|
||||
let relPfx = mkObjRelTableAls pfx rn
|
||||
((nesAls, nesCol), nesNodeM) = processAnnOrderByCol relPfx rest
|
||||
qualCol = S.mkQIdenExp relPfx nesAls
|
||||
relBaseNode =
|
||||
BaseNode relPfx (S.FISimple relTab Nothing) relFltr
|
||||
Nothing Nothing Nothing
|
||||
(HM.singleton nesAls nesCol)
|
||||
(maybe HM.empty (uncurry HM.singleton) nesNodeM)
|
||||
HM.empty HM.empty
|
||||
relNode = RelNode rn (fromRel rn) colMapping relBaseNode
|
||||
in ( (nesAls, qualCol)
|
||||
, Just (rn, relNode)
|
||||
)
|
||||
|
||||
mkEmptyBaseNode :: Iden -> TableFrom -> BaseNode
|
||||
mkEmptyBaseNode pfx tableFrom =
|
||||
BaseNode pfx fromItem (S.BELit True) Nothing Nothing Nothing
|
||||
selOne HM.empty HM.empty HM.empty
|
||||
where
|
||||
selOne = HM.singleton (S.Alias $ pfx <> Iden "__one") (S.SEUnsafe "1")
|
||||
TableFrom tn fromItemM = tableFrom
|
||||
fromItem = fromMaybe (S.FISimple tn Nothing) fromItemM
|
||||
|
||||
-- If query limit > permission limit then consider permission limit Else consider query limit
|
||||
applyPermLimit
|
||||
:: Maybe Int -- Permission limit
|
||||
-> Maybe Int -- Query limit
|
||||
-> Maybe Int -- Return SQL exp
|
||||
applyPermLimit mPermLimit mQueryLimit =
|
||||
maybe mQueryLimit compareWithPermLimit mPermLimit
|
||||
where
|
||||
compareWithPermLimit pLimit =
|
||||
maybe (Just pLimit) (compareLimits pLimit) mQueryLimit
|
||||
compareLimits pLimit qLimit = Just $
|
||||
if qLimit > pLimit then pLimit else qLimit
|
||||
|
||||
aggSelToAggNode :: Iden -> FieldName -> AggSel -> AggNode
|
||||
aggSelToAggNode pfx als aggSel =
|
||||
AggNode colMapping extr mergedBN
|
||||
where
|
||||
AggSel colMapping annSel = aggSel
|
||||
AnnSelG aggFlds tabFrm tabPerm tabArgs = annSel
|
||||
fldAls = S.Alias $ toIden als
|
||||
|
||||
extr = flip S.Extractor (Just fldAls) $ S.applyJsonBuildObj $
|
||||
concatMap selFldToExtr aggFlds
|
||||
|
||||
ordBy = _bnOrderBy mergedBN
|
||||
|
||||
allBNs = map mkAggBaseNode aggFlds
|
||||
emptyBN = mkEmptyBaseNode pfx tabFrm
|
||||
mergedBN = foldr mergeBaseNodes emptyBN allBNs
|
||||
|
||||
mkAggBaseNode (t, selFld) =
|
||||
mkBaseNode pfx (FieldName t) selFld tabFrm tabPerm tabArgs
|
||||
|
||||
selFldToExtr (t, fld) = (:) (S.SELit t) $ pure $ case fld of
|
||||
TAFAgg flds ->
|
||||
aggFldToExp pfx flds
|
||||
TAFNodes _ ->
|
||||
let jsonAgg = S.SEFnApp "json_agg" [S.SEIden $ Iden t] ordBy
|
||||
in S.SEFnApp "coalesce" [jsonAgg, S.SELit "[]"] Nothing
|
||||
TAFExp e ->
|
||||
-- bool_or to force aggregation
|
||||
S.SEFnApp "coalesce"
|
||||
[ S.SELit e , S.SEUnsafe "bool_or('true')::text"] Nothing
|
||||
|
||||
mkBaseNode
|
||||
:: Iden -> FieldName -> TableAggFld -> TableFrom
|
||||
-> TablePerm -> TableArgs -> BaseNode
|
||||
mkBaseNode pfx fldAls annSelFlds tableFrom tablePerm tableArgs =
|
||||
BaseNode pfx fromItem finalWhere ordByExpM finalLimit offsetM
|
||||
allExtrs allObjsWithOb allArrs aggs
|
||||
where
|
||||
TableFrom tn fromItemM = tableFrom
|
||||
TablePerm fltr permLimitM = tablePerm
|
||||
TableArgs whereM orderByM limitM offsetM = tableArgs
|
||||
(allExtrs, allObjsWithOb, allArrs, aggs) = case annSelFlds of
|
||||
TAFNodes flds ->
|
||||
let selExtr = buildJsonObject pfx fldAls flds
|
||||
-- all the relationships
|
||||
(allObjs, allArrRels) =
|
||||
foldl' addRel (HM.empty, HM.empty) $
|
||||
mapMaybe (\(als, f) -> (als,) <$> getAnnRel f) flds
|
||||
allObjRelsWithOb =
|
||||
foldl' (\objs (rn, relNode) -> HM.insertWith mergeRelNodes rn relNode objs)
|
||||
allObjs $ catMaybes $ maybe [] _3 procOrdByM
|
||||
aggItems = HM.fromList $ map mkAggItem $
|
||||
mapMaybe (\(als, f) -> (als,) <$> getAggFld f) flds
|
||||
in ( HM.fromList $ selExtr:obExtrs
|
||||
, allObjRelsWithOb
|
||||
, allArrRels
|
||||
, aggItems
|
||||
)
|
||||
TAFAgg aggFlds ->
|
||||
let extrs = concatMap (fetchExtrFromAggFld . snd) aggFlds
|
||||
in ( HM.fromList $ extrs <> obExtrs
|
||||
, HM.empty
|
||||
, HM.empty
|
||||
, HM.empty
|
||||
)
|
||||
TAFExp _ -> (HM.fromList obExtrs, HM.empty, HM.empty, HM.empty)
|
||||
|
||||
fetchExtrFromAggFld AFCount = []
|
||||
fetchExtrFromAggFld (AFSum sumFlds) = colFldsToExps sumFlds
|
||||
fetchExtrFromAggFld (AFAvg avgFlds) = colFldsToExps avgFlds
|
||||
fetchExtrFromAggFld (AFMax maxFlds) = colFldsToExps maxFlds
|
||||
fetchExtrFromAggFld (AFMin minFlds) = colFldsToExps minFlds
|
||||
fetchExtrFromAggFld (AFExp _) = []
|
||||
|
||||
colFldsToExps = mapMaybe (mkColExp . snd)
|
||||
|
||||
mkColExp (PCFCol c) =
|
||||
let qualCol = S.mkQIdenExp (mkBaseTableAls pfx) (toIden c)
|
||||
colAls = mkBaseTableColAls pfx c
|
||||
in Just (S.Alias colAls, qualCol)
|
||||
mkColExp _ = Nothing
|
||||
|
||||
finalWhere = maybe fltr (S.BEBin S.AndOp fltr . cBoolExp) whereM
|
||||
finalLimit = applyPermLimit permLimitM limitM
|
||||
|
||||
fromItem = fromMaybe (S.FISimple tn Nothing) fromItemM
|
||||
|
||||
_1 (a, _, _) = a
|
||||
_2 (_, b, _) = b
|
||||
_3 (_, _, c) = c
|
||||
|
||||
procOrdByM = unzip3 . map (processAnnOrderByItem pfx) . toList <$> orderByM
|
||||
ordByExpM = S.OrderByExp . _2 <$> procOrdByM
|
||||
|
||||
-- the columns needed for orderby
|
||||
obExtrs = maybe [] _1 procOrdByM
|
||||
|
||||
mkRelPfx rTy rn relAls = case rTy of
|
||||
ObjRel -> mkObjRelTableAls pfx rn
|
||||
ArrRel -> mkArrRelTableAls pfx fldAls relAls
|
||||
|
||||
-- process a relationship
|
||||
addRel (objs, arrs) (relAls, annRel) =
|
||||
let relName = arName annRel
|
||||
relNodePfx = mkRelPfx (arType annRel) relName relAls
|
||||
relNode = mkRelNode relNodePfx (relAls, annRel)
|
||||
in case arType annRel of
|
||||
-- in case of object relationships, we merge
|
||||
ObjRel ->
|
||||
(HM.insertWith mergeRelNodes relName relNode objs, arrs)
|
||||
ArrRel ->
|
||||
let arrRelTableAls = S.Alias $ mkUniqArrRelAls fldAls relAls
|
||||
in (objs, HM.insert arrRelTableAls relNode arrs)
|
||||
|
||||
-- process agg field
|
||||
mkAggItem (f, aggSel) =
|
||||
let aggPfx = mkAggAls pfx f
|
||||
aggAls = S.Alias aggPfx
|
||||
aggNode = aggSelToAggNode aggPfx f aggSel
|
||||
in (aggAls, aggNode)
|
||||
|
||||
getAnnRel = \case
|
||||
FRel ar -> Just ar
|
||||
_ -> Nothing
|
||||
|
||||
getAggFld = \case
|
||||
FAgg af -> Just af
|
||||
_ -> Nothing
|
||||
|
||||
annSelToBaseNode :: Iden -> FieldName -> AnnSel -> BaseNode
|
||||
annSelToBaseNode pfx fldAls annSel =
|
||||
mkBaseNode pfx fldAls (TAFNodes selFlds) tabFrm tabPerm tabArgs
|
||||
where
|
||||
AnnSelG selFlds tabFrm tabPerm tabArgs = annSel
|
||||
|
||||
mergeBaseNodes :: BaseNode -> BaseNode -> BaseNode
|
||||
mergeBaseNodes lNodeDet rNodeDet =
|
||||
BaseNode pfx f whr ordBy limit offset
|
||||
(HM.union lExtrs rExtrs)
|
||||
(HM.unionWith mergeRelNodes lObjs rObjs)
|
||||
(HM.union lArrs rArrs)
|
||||
(HM.union lAggs rAggs)
|
||||
where
|
||||
(BaseNode pfx f whr ordBy limit offset lExtrs lObjs lArrs lAggs) = lNodeDet
|
||||
(BaseNode _ _ _ _ _ _ rExtrs rObjs rArrs rAggs) = rNodeDet
|
||||
|
||||
-- should only be used to merge obj rel nodes
|
||||
mergeRelNodes :: RelNode -> RelNode -> RelNode
|
||||
mergeRelNodes lNode rNode =
|
||||
RelNode rn rAls rMapn $ mergeBaseNodes lNodeDet rNodeDet
|
||||
where
|
||||
(RelNode rn rAls rMapn lNodeDet) = lNode
|
||||
(RelNode _ _ _ rNodeDet) = rNode
|
||||
|
||||
data RelNode
|
||||
= RelNode
|
||||
{ _rnRelName :: !RelName
|
||||
, _rnRelAlias :: !FieldName
|
||||
, _rnRelMapping :: ![(PGCol, PGCol)]
|
||||
, _rnNodeDet :: !BaseNode
|
||||
} deriving (Show, Eq)
|
||||
|
||||
mkRelNode :: Iden -> (FieldName, AnnRel) -> RelNode
|
||||
mkRelNode pfx (relAls, AnnRel rn _ rMapn rAnnSel) =
|
||||
RelNode rn relAls rMapn $ annSelToBaseNode pfx relAls rAnnSel
|
||||
|
||||
data AggNode
|
||||
= AggNode
|
||||
{ _anColMapping :: ![(PGCol, PGCol)]
|
||||
, _anExtr :: !S.Extractor
|
||||
, _anNodeDet :: !BaseNode
|
||||
} deriving (Show, Eq)
|
||||
|
||||
injectJoinCond :: S.BoolExp -- ^ Join condition
|
||||
-> S.BoolExp -- ^ Where condition
|
||||
-> S.WhereFrag -- ^ New where frag
|
||||
injectJoinCond joinCond whereCond =
|
||||
S.WhereFrag $ S.simplifyBoolExp $ S.BEBin S.AndOp joinCond whereCond
|
||||
|
||||
mkJoinCond :: S.Alias -> [(PGCol, PGCol)] -> S.BoolExp
|
||||
mkJoinCond baseTableAls colMapn =
|
||||
foldl' (S.BEBin S.AndOp) (S.BELit True) $ flip map colMapn $
|
||||
\(lCol, rCol) ->
|
||||
S.BECompare S.SEQ (S.mkQIdenExp baseTableAls lCol) (S.mkSIdenExp rCol)
|
||||
|
||||
baseNodeToSel :: S.BoolExp -> BaseNode -> S.Select
|
||||
baseNodeToSel joinCond (BaseNode pfx fromItem whr ordByM limitM offsetM extrs objRels arrRels aggs) =
|
||||
S.mkSelect
|
||||
{ S.selExtr = [S.Extractor e $ Just a | (a, e) <- HM.toList extrs]
|
||||
, S.selFrom = Just $ S.FromExp [joinedFrom]
|
||||
, S.selOrderBy = ordByM
|
||||
, S.selLimit = S.LimitExp . S.intToSQLExp <$> limitM
|
||||
, S.selOffset = S.OffsetExp <$> offsetM
|
||||
}
|
||||
where
|
||||
-- this is the table which is aliased as "pfx.base"
|
||||
baseSel = S.mkSelect
|
||||
{ S.selExtr = [S.Extractor S.SEStar Nothing]
|
||||
, S.selFrom = Just $ S.FromExp [fromItem]
|
||||
, S.selWhere = Just $ injectJoinCond joinCond whr
|
||||
}
|
||||
baseSelAls = S.Alias $ mkBaseTableAls pfx
|
||||
baseFromItem = S.FISelect (S.Lateral False) baseSel baseSelAls
|
||||
|
||||
-- function to create a joined from item from two from items
|
||||
leftOuterJoin current new =
|
||||
S.FIJoin $ S.JoinExpr current S.LeftOuter new $
|
||||
S.JoinOn $ S.BELit True
|
||||
|
||||
-- this is the from eexp for the final select
|
||||
joinedFrom :: S.FromItem
|
||||
joinedFrom = foldl' leftOuterJoin baseFromItem $
|
||||
map objRelToFromItem (HM.elems objRels) <>
|
||||
map arrRelToFromItem (HM.elems arrRels) <>
|
||||
map aggToFromItem (HM.toList aggs)
|
||||
|
||||
objRelToFromItem :: RelNode -> S.FromItem
|
||||
objRelToFromItem (RelNode _ _ relMapn relBaseNode) =
|
||||
let als = S.Alias $ _bnPrefix relBaseNode
|
||||
sel = baseNodeToSel (mkJoinCond baseSelAls relMapn) relBaseNode
|
||||
in S.mkLateralFromItem sel als
|
||||
|
||||
arrRelToFromItem :: RelNode -> S.FromItem
|
||||
arrRelToFromItem (RelNode _ relFld relMapn relBaseNode) =
|
||||
let als = S.Alias $ _bnPrefix relBaseNode
|
||||
fldAls = S.Alias $ toIden relFld
|
||||
sel = asJsonAggSel False fldAls (mkJoinCond baseSelAls relMapn) relBaseNode
|
||||
in S.mkLateralFromItem sel als
|
||||
|
||||
aggToFromItem :: (S.Alias, AggNode) -> S.FromItem
|
||||
aggToFromItem (als, AggNode colMapn extr bn) =
|
||||
let sel = aggNodeToSelect bn extr (mkJoinCond baseSelAls colMapn)
|
||||
in S.mkLateralFromItem sel als
|
||||
Loading…
Reference in New Issue
Block a user