1
0
mirror of https://github.com/hasura/graphql-engine.git synced 2024-12-21 14:31:55 +03:00
graphql-engine/server/src-lib/Hasura/Backends/Postgres/Execute/Insert.hs
2021-07-29 08:30:10 +00:00

346 lines
13 KiB
Haskell

module Hasura.Backends.Postgres.Execute.Insert
( convertToSQLTransaction
) where
import Hasura.Prelude
import qualified Data.Aeson as J
import qualified Data.HashMap.Strict as Map
import qualified Data.List as L
import qualified Data.Sequence as Seq
import qualified Data.Text as T
import qualified Database.PG.Query as Q
import Data.Text.Extended
import qualified Hasura.Backends.Postgres.Execute.Mutation as PGE
import qualified Hasura.Backends.Postgres.SQL.DML as PG
import qualified Hasura.Backends.Postgres.Translate.BoolExp as PGT
import qualified Hasura.Backends.Postgres.Translate.Insert as PGT
import qualified Hasura.Backends.Postgres.Translate.Mutation as PGT
import qualified Hasura.Backends.Postgres.Translate.Returning as PGT
import qualified Hasura.RQL.IR.Insert as IR
import qualified Hasura.RQL.IR.Returning as IR
import qualified Hasura.Tracing as Tracing
import Hasura.Backends.Postgres.Connection
import Hasura.Backends.Postgres.SQL.Types
import Hasura.Backends.Postgres.SQL.Value
import Hasura.Backends.Postgres.Translate.Select (PostgresAnnotatedFieldJSON)
import Hasura.Base.Error
import Hasura.EncJSON
import Hasura.QueryTags
import Hasura.RQL.Types
import Hasura.Server.Version (HasVersion)
import Hasura.Session
convertToSQLTransaction
:: forall pgKind m
. ( HasVersion
, MonadTx m
, MonadIO m
, Tracing.MonadTrace m
, Backend ('Postgres pgKind)
, PostgresAnnotatedFieldJSON pgKind
, MonadReader QueryTagsComment m
)
=> IR.AnnInsert ('Postgres pgKind) (Const Void) PG.SQLExp
-> UserInfo
-> Seq.Seq Q.PrepArg
-> Bool
-> m EncJSON
convertToSQLTransaction (IR.AnnInsert fieldName isSingle annIns mutationOutput) userInfo planVars stringifyNum =
if null $ IR._aiInsObj annIns
then pure $ IR.buildEmptyMutResp mutationOutput
else withPaths ["selectionSet", fieldName, "args", suffix] $
insertMultipleObjects annIns [] userInfo mutationOutput planVars stringifyNum
where
withPaths p x = foldr ($) x $ withPathK <$> p
suffix = bool "objects" "object" isSingle
insertMultipleObjects
:: forall pgKind m
. ( HasVersion
, MonadTx m
, MonadIO m
, Tracing.MonadTrace m
, Backend ('Postgres pgKind)
, PostgresAnnotatedFieldJSON pgKind
, MonadReader QueryTagsComment m
)
=> IR.MultiObjIns ('Postgres pgKind) PG.SQLExp
-> [(PGCol, PG.SQLExp)]
-> UserInfo
-> IR.MutationOutput ('Postgres pgKind)
-> Seq.Seq Q.PrepArg
-> Bool
-> m EncJSON
insertMultipleObjects multiObjIns additionalColumns userInfo mutationOutput planVars stringifyNum =
bool withoutRelsInsert withRelsInsert anyRelsToInsert
where
IR.AnnIns insObjs table conflictClause checkCondition columnInfos defVals = multiObjIns
allInsObjRels = concatMap IR._aioObjRels insObjs
allInsArrRels = concatMap IR._aioArrRels insObjs
anyRelsToInsert = not $ null allInsArrRels && null allInsObjRels
withoutRelsInsert = do
indexedForM_ (IR._aioColumns <$> insObjs) \column ->
validateInsert (map fst column) [] (map fst additionalColumns)
let columnValues = map (mkSQLRow defVals) $ union additionalColumns . IR._aioColumns <$> insObjs
columnNames = Map.keys defVals
insertQuery = IR.InsertQueryP1
table
columnNames
columnValues
conflictClause
checkCondition
mutationOutput
columnInfos
rowCount = tshow . length $ IR._aiInsObj multiObjIns
Tracing.trace ("Insert (" <> rowCount <> ") " <> qualifiedObjectToText table) do
Tracing.attachMetadata [("count", rowCount)]
PGE.execInsertQuery stringifyNum userInfo (insertQuery, planVars)
withRelsInsert = do
insertRequests <- indexedForM insObjs \obj -> do
let singleObj = IR.AnnIns (IR.Single obj) table conflictClause checkCondition columnInfos defVals
insertObject singleObj additionalColumns userInfo planVars stringifyNum
let affectedRows = sum $ map fst insertRequests
columnValues = mapMaybe snd insertRequests
selectExpr <- PGT.mkSelectExpFromColumnValues table columnInfos columnValues
PGE.executeMutationOutputQuery table columnInfos (Just affectedRows) (PGT.MCSelectValues selectExpr)
mutationOutput stringifyNum []
insertObject
:: forall pgKind m
. ( HasVersion
, MonadTx m
, MonadIO m
, Tracing.MonadTrace m
, Backend ('Postgres pgKind)
, PostgresAnnotatedFieldJSON pgKind
, MonadReader QueryTagsComment m
)
=> IR.SingleObjIns ('Postgres pgKind) PG.SQLExp
-> [(PGCol, PG.SQLExp)]
-> UserInfo
-> Seq.Seq Q.PrepArg
-> Bool
-> m (Int, Maybe (ColumnValues ('Postgres pgKind) TxtEncodedVal))
insertObject singleObjIns additionalColumns userInfo planVars stringifyNum = Tracing.trace ("Insert " <> qualifiedObjectToText table) do
validateInsert (map fst columns) (map IR._riRelInfo objectRels) (map fst additionalColumns)
-- insert all object relations and fetch this insert dependent column values
objInsRes <- forM beforeInsert $ insertObjRel planVars userInfo stringifyNum
-- prepare final insert columns
let objRelAffRows = sum $ map fst objInsRes
objRelDeterminedCols = concatMap snd objInsRes
finalInsCols = columns <> objRelDeterminedCols <> additionalColumns
cte <- mkInsertQ table onConflict finalInsCols defaultValues checkCond
PGE.MutateResp affRows colVals <- liftTx $
PGE.mutateAndFetchCols @pgKind table allColumns (PGT.MCCheckConstraint cte, planVars) stringifyNum
colValM <- asSingleObject colVals
arrRelAffRows <- bool (withArrRels colValM) (return 0) $ null allAfterInsertRels
let totAffRows = objRelAffRows + affRows + arrRelAffRows
return (totAffRows, colValM)
where
IR.AnnIns (IR.Single annObj) table onConflict checkCond allColumns defaultValues = singleObjIns
IR.AnnInsObj columns objectRels arrayRels = annObj
afterInsert, beforeInsert :: [IR.ObjRelIns ('Postgres pgKind) PG.SQLExp]
(afterInsert, beforeInsert) =
L.partition ((== AfterParent) . riInsertOrder . IR._riRelInfo) objectRels
allAfterInsertRels :: [IR.ArrRelIns ('Postgres pgKind) PG.SQLExp]
allAfterInsertRels = arrayRels <> map objToArr afterInsert
afterInsertDepCols :: [ColumnInfo ('Postgres pgKind)]
afterInsertDepCols = flip (getColInfos @('Postgres pgKind)) allColumns $
concatMap (Map.keys . riMapping . IR._riRelInfo) allAfterInsertRels
objToArr :: forall a b. IR.ObjRelIns b a -> IR.ArrRelIns b a
objToArr IR.RelIns {..} = IR.RelIns (singleToMulti _riAnnIns) _riRelInfo
singleToMulti :: forall a b. IR.SingleObjIns b a -> IR.MultiObjIns b a
singleToMulti IR.AnnIns {..} =
IR.AnnIns
[IR.unSingle _aiInsObj]
_aiTableName
_aiConflictClause
_aiCheckCond
_aiTableCols
_aiDefVals
withArrRels
:: Maybe (ColumnValues ('Postgres pgKind) TxtEncodedVal)
-> m Int
withArrRels colValM = do
colVal <- onNothing colValM $ throw400 NotSupported cannotInsArrRelErr
afterInsertDepColsWithVal <- fetchFromColVals colVal afterInsertDepCols
arrInsARows <- forM allAfterInsertRels
$ insertArrRel afterInsertDepColsWithVal userInfo planVars stringifyNum
return $ sum arrInsARows
asSingleObject
:: [ColumnValues ('Postgres pgKind) TxtEncodedVal]
-> m (Maybe (ColumnValues ('Postgres pgKind) TxtEncodedVal))
asSingleObject = \case
[] -> pure Nothing
[r] -> pure $ Just r
_ -> throw500 "more than one row returned"
cannotInsArrRelErr :: Text
cannotInsArrRelErr =
"cannot proceed to insert array relations since insert to table "
<> table <<> " affects zero rows"
insertObjRel
:: forall pgKind m
. ( HasVersion
, MonadTx m
, MonadIO m
, Tracing.MonadTrace m
, Backend ('Postgres pgKind)
, PostgresAnnotatedFieldJSON pgKind
, MonadReader QueryTagsComment m
)
=> Seq.Seq Q.PrepArg
-> UserInfo
-> Bool
-> IR.ObjRelIns ('Postgres pgKind) PG.SQLExp
-> m (Int, [(PGCol, PG.SQLExp)])
insertObjRel planVars userInfo stringifyNum objRelIns =
withPathK (relNameToTxt relName) $ do
(affRows, colValM) <- withPathK "data" $ insertObject singleObjIns [] userInfo planVars stringifyNum
colVal <- onNothing colValM $ throw400 NotSupported errMsg
retColsWithVals <- fetchFromColVals colVal rColInfos
let columns = flip mapMaybe (Map.toList mapCols) \(column, target) -> do
value <- lookup target retColsWithVals
Just (column, value)
pure (affRows, columns)
where
IR.RelIns singleObjIns relInfo = objRelIns
relName = riName relInfo
table = riRTable relInfo
mapCols = riMapping relInfo
allCols = IR._aiTableCols singleObjIns
rCols = Map.elems mapCols
rColInfos = getColInfos rCols allCols
errMsg = "cannot proceed to insert object relation "
<> relName <<> " since insert to table "
<> table <<> " affects zero rows"
insertArrRel
:: ( HasVersion
, MonadTx m
, MonadIO m
, Tracing.MonadTrace m
, Backend ('Postgres pgKind)
, PostgresAnnotatedFieldJSON pgKind
, MonadReader QueryTagsComment m
)
=> [(PGCol, PG.SQLExp)]
-> UserInfo
-> Seq.Seq Q.PrepArg
-> Bool
-> IR.ArrRelIns ('Postgres pgKind) PG.SQLExp
-> m Int
insertArrRel resCols userInfo planVars stringifyNum arrRelIns =
withPathK (relNameToTxt $ riName relInfo) $ do
let additionalColumns = flip mapMaybe resCols \(column, value) -> do
target <- Map.lookup column mapping
Just (target, value)
resBS <- withPathK "data" $
insertMultipleObjects multiObjIns additionalColumns userInfo mutOutput planVars stringifyNum
resObj <- decodeEncJSON resBS
onNothing (Map.lookup ("affected_rows" :: Text) resObj) $
throw500 "affected_rows not returned in array rel insert"
where
IR.RelIns multiObjIns relInfo = arrRelIns
mapping = riMapping relInfo
mutOutput = IR.MOutMultirowFields [("affected_rows", IR.MCount)]
-- | validate an insert object based on insert columns,
-- | insert object relations and additional columns from parent
validateInsert
:: (MonadError QErr m)
=> [PGCol] -- ^ inserting columns
-> [RelInfo ('Postgres pgKind)] -- ^ object relation inserts
-> [PGCol] -- ^ additional fields from parent
-> m ()
validateInsert insCols objRels addCols = do
-- validate insertCols
unless (null insConflictCols) $ throw400 ValidationFailed $
"cannot insert " <> showPGCols insConflictCols
<> " columns as their values are already being determined by parent insert"
forM_ objRels $ \relInfo -> do
let lCols = Map.keys $ riMapping relInfo
relName = riName relInfo
relNameTxt = relNameToTxt relName
lColConflicts = lCols `intersect` (addCols <> insCols)
withPathK relNameTxt $ unless (null lColConflicts) $ throw400 ValidationFailed $
"cannot insert object relationship " <> relName
<<> " as " <> showPGCols lColConflicts
<> " column values are already determined"
where
insConflictCols = insCols `intersect` addCols
mkInsertQ
:: (MonadError QErr m, Backend ('Postgres pgKind))
=> QualifiedTable
-> Maybe (IR.ConflictClauseP1 ('Postgres pgKind) PG.SQLExp)
-> [(PGCol, PG.SQLExp)]
-> Map.HashMap PGCol PG.SQLExp
-> (AnnBoolExpSQL ('Postgres pgKind), Maybe (AnnBoolExpSQL ('Postgres pgKind)))
-> m PG.CTE
mkInsertQ table onConflictM insCols defVals (insCheck, updCheck) = do
let sqlConflict = PGT.toSQLConflict table <$> onConflictM
sqlExps = mkSQLRow defVals insCols
valueExp = PG.ValuesExp [PG.TupleExp sqlExps]
tableCols = Map.keys defVals
sqlInsert =
PG.SQLInsert table tableCols valueExp sqlConflict
. Just
$ PG.RetExp
[ PG.selectStar
, PGT.insertOrUpdateCheckExpr table onConflictM
(PGT.toSQLBoolExp (PG.QualTable table) insCheck)
(fmap (PGT.toSQLBoolExp (PG.QualTable table)) updCheck)
]
pure $ PG.CTEInsert sqlInsert
fetchFromColVals
:: MonadError QErr m
=> ColumnValues ('Postgres pgKind) TxtEncodedVal
-> [ColumnInfo ('Postgres pgKind)]
-> m [(PGCol, PG.SQLExp)]
fetchFromColVals colVal reqCols =
forM reqCols $ \ci -> do
let valM = Map.lookup (pgiColumn ci) colVal
val <- onNothing valM $ throw500 $ "column "
<> pgiColumn ci <<> " not found in given colVal"
let pgColVal = case val of
TENull -> PG.SENull
TELit t -> PG.SELit t
return (pgiColumn ci, pgColVal)
mkSQLRow :: Map.HashMap PGCol PG.SQLExp -> [(PGCol, PG.SQLExp)] -> [PG.SQLExp]
mkSQLRow defVals withPGCol = map snd $
flip map (Map.toList defVals) $
\(col, defVal) -> (col,) $ fromMaybe defVal $ Map.lookup col withPGColMap
where
withPGColMap = Map.fromList withPGCol
decodeEncJSON :: (J.FromJSON a, QErrM m) => EncJSON -> m a
decodeEncJSON =
either (throw500 . T.pack) decodeValue .
J.eitherDecode . encJToLBS