diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,12 @@ +# 0.6.4.0 + +## Added features + +* Added `pgInsertOnly` for partial-column PostgreSQL inserts with `ON CONFLICT` + support. The resulting `SqlInsert` composes with `returning`, `cteInsertCommand`, + and `cteInsertCommandReturning`, allowing generated and defaulted columns to be + exposed by a data-modifying CTE without duplicating insert builders. + # 0.6.3.0 ## Added features diff --git a/Database/Beam/Postgres/Full.hs b/Database/Beam/Postgres/Full.hs --- a/Database/Beam/Postgres/Full.hs +++ b/Database/Beam/Postgres/Full.hs @@ -38,7 +38,8 @@ , lateral_ -- * @INSERT@ and @INSERT RETURNING@ - , insert, insertReturning, cteInsert, cteInsertReturning + , insert, pgInsertOnly, insertReturning + , cteInsert, cteInsertReturning, cteInsertCommand, cteInsertCommandReturning , insertDefaults , runPgInsertReturningList @@ -69,6 +70,7 @@ ) where import Database.Beam hiding (insert, insertValues) +import qualified Database.Beam as Beam import Database.Beam.Backend.SQL import Database.Beam.Backend.SQL.BeamExtensions import qualified Database.Beam.Query.CTE as CTE @@ -397,19 +399,47 @@ -- | A @beam-postgres@-specific version of 'Database.Beam.Query.insert', which -- provides fuller support for the much richer Postgres @INSERT@ syntax. This -- allows you to specify @ON CONFLICT@ actions. For even more complete support, --- see 'insertReturning'. +-- see 'insertReturning'. For a partial target-column projection, see 'pgInsertOnly'. insert :: DatabaseEntity Postgres db (TableEntity table) - -> SqlInsertValues Postgres (table (QExpr Postgres s)) -- TODO arbitrary projectibles + -> SqlInsertValues Postgres (table (QExpr Postgres s)) -> PgInsertOnConflict table -> SqlInsert Postgres table -insert tbl@(DatabaseEntity dt@(DatabaseTable {})) values onConflict_ = - case insertReturning tbl values onConflict_ - (Nothing :: Maybe (table (QExpr Postgres PostgresInaccessible) -> QExpr Postgres PostgresInaccessible Int)) of - PgInsertReturning a -> - SqlInsert (dbTableSettings dt) (PgInsertSyntax a) - PgInsertReturningEmpty -> - SqlInsertNoRows +insert tbl@(DatabaseEntity (DatabaseTable {})) values = + pgInsertOnly tbl id values +-- | Build a PostgreSQL insert over a caller-selected subset of table fields, +-- with support for 'PgInsertOnConflict'. Beam's backend-independent +-- 'Beam.insertOnly' owns the typed field projection and base @INSERT@ +-- rendering; this function adds PostgreSQL's @ON CONFLICT@ extension. +-- +-- Beam also provides backend-independent conflict handling through +-- 'BeamHasInsertOnConflict'. Its 'insertOnConflict' method accepts full-table +-- values; 'pgInsertOnly' adds partial-target selection with conflict handling. +-- This matters for @INSERT ... SELECT@: 'default_' can appear in an @INSERT@ +-- @VALUES@ list, but cannot stand in for an omitted column in a @SELECT@. +-- +-- @since 0.6.4.0 +pgInsertOnly + :: ProjectibleWithPredicate AnyType () Text (QExprToField r) + => DatabaseEntity Postgres db (TableEntity table) + -> (table (QField s) -> QExprToField r) + -> SqlInsertValues Postgres r + -> PgInsertOnConflict table + -> SqlInsert Postgres table +pgInsertOnly tbl@(DatabaseEntity dt@(DatabaseTable {})) mkProjection values + (PgInsertOnConflict mkOnConflict) = + case Beam.insertOnly tbl mkProjection values of + SqlInsertNoRows -> SqlInsertNoRows + SqlInsert settings (PgInsertSyntax syntax) -> + SqlInsert settings . PgInsertSyntax $ + syntax <> emit " " <> fromPgInsertOnConflict (mkOnConflict tblFields) + where + tblFields = + changeBeamRep + (\(Columnar' f) -> + Columnar' (QField True (dbTableCurrentName dt) (_fieldName f))) + (dbTableSettings dt) + -- | The most general kind of @INSERT@ that postgres can perform data PgInsertReturning a = PgInsertReturning PgSyntax @@ -429,25 +459,14 @@ -> Maybe (table (QExpr Postgres PostgresInaccessible) -> a) -> PgInsertReturning (QExprToIdentity a) -insertReturning _ SqlInsertValuesEmpty _ _ = PgInsertReturningEmpty -insertReturning (DatabaseEntity tbl@(DatabaseTable {})) - (SqlInsertValues (PgInsertValuesSyntax insertValues_)) - (PgInsertOnConflict mkOnConflict) +insertReturning table@(DatabaseEntity (DatabaseTable {})) values onConflict_ mMkProjection = - PgInsertReturning $ - emit "INSERT INTO " <> fromPgTableName (tableName (dbTableSchema tbl) (dbTableCurrentName tbl)) <> - emit "(" <> pgSepBy (emit ", ") (allBeamValues (\(Columnar' f) -> pgQuotedIdentifier (_fieldName f)) tblSettings) <> emit ") " <> - insertValues_ <> emit " " <> fromPgInsertOnConflict (mkOnConflict tblFields) <> - (case mMkProjection of - Nothing -> mempty - Just mkProjection -> - emit " RETURNING " <> - pgSepBy (emit ", ") (map fromPgExpression (project (Proxy @Postgres) (mkProjection tblQ) "t"))) - where - tblQ = changeBeamRep (\(Columnar' f) -> Columnar' (QExpr (\_ -> fieldE (unqualifiedField (_fieldName f))))) tblSettings - tblFields = changeBeamRep (\(Columnar' f) -> Columnar' (QField True (dbTableCurrentName tbl) (_fieldName f))) tblSettings - - tblSettings = dbTableSettings tbl + case insert table values onConflict_ of + SqlInsertNoRows -> PgInsertReturningEmpty + statement@(SqlInsert _ (PgInsertSyntax syntax)) -> + case mMkProjection of + Nothing -> PgInsertReturning syntax + Just mkProjection -> returning statement mkProjection -- | Introduce a PostgreSQL @INSERT@ statement as a side-effect-only CTE. -- @@ -477,10 +496,28 @@ -> PgInsertOnConflict table -> PgWith db 'PgCteTopLevelOnly () cteInsert table values onConflict_ = - case insert table values onConflict_ of - SqlInsertNoRows -> pure () - SqlInsert _ (PgInsertSyntax syntax) -> pgDataModifyingCte_ syntax + cteInsertCommand (insert table values onConflict_) +-- | Introduce an already-built PostgreSQL @INSERT@ statement as a +-- side-effect-only CTE. This is the command-level counterpart to 'cteInsert': +-- it composes with any insert builder which produces 'SqlInsert', including +-- 'pgInsertOnly'. +-- +-- 'SqlInsert' does not carry the target table's database type, so that type is +-- not tied to the enclosing 'PgWith' block. +-- +-- Empty inserts register no CTE. The result remains conservatively indexed as +-- 'PgCteTopLevelOnly', because the placement index cannot vary with the +-- supplied command. +-- +-- @since 0.6.4.0 +cteInsertCommand + :: SqlInsert Postgres table + -> PgWith db 'PgCteTopLevelOnly () +cteInsertCommand SqlInsertNoRows = pure () +cteInsertCommand (SqlInsert _ (PgInsertSyntax syntax)) = + pgDataModifyingCte_ syntax + -- | Introduce a PostgreSQL @INSERT ... RETURNING@ statement as a -- data-modifying common table expression. The returned value can be used in a -- subsequent query with 'reuse'. @@ -538,8 +575,37 @@ -> PgInsertOnConflict table -> (table (QExpr Postgres PostgresInaccessible) -> a) -> PgWith db 'PgCteTopLevelOnly (Maybe (ReusableQ Postgres db (WithRewrittenThread PostgresInaccessible CTE.QAnyScope a))) -cteInsertReturning table values onConflict_ mkProjection = - case insertReturning table values onConflict_ (Just mkProjection) of +cteInsertReturning table@(DatabaseEntity (DatabaseTable {})) + values onConflict_ mkProjection = + cteInsertCommandReturning + (insert table values onConflict_) + mkProjection + +-- | Attach a @RETURNING@ projection to an already-built PostgreSQL @INSERT@ +-- and introduce it as a reusable data-modifying CTE. Keeping insert +-- construction separate lets this function compose with both full-row +-- 'insert' and partial-row 'pgInsertOnly' commands. +-- +-- 'SqlInsert' does not carry the target table's database type, so that type is +-- not tied to the enclosing 'PgWith' block. +-- +-- Returns 'Nothing' for 'SqlInsertNoRows'. A real command which affects no +-- rows, such as @ON CONFLICT DO NOTHING@, still returns a reusable relation; +-- that relation simply produces no rows when the statement executes. +-- +-- @since 0.6.4.0 +cteInsertCommandReturning + :: ( Beamable table + , Projectible Postgres a + , ThreadRewritable PostgresInaccessible a + , Projectible Postgres (WithRewrittenThread PostgresInaccessible CTE.QAnyScope a) + , ThreadRewritable CTE.QAnyScope (WithRewrittenThread PostgresInaccessible CTE.QAnyScope a) + ) + => SqlInsert Postgres table + -> (table (QExpr Postgres PostgresInaccessible) -> a) + -> PgWith db 'PgCteTopLevelOnly (Maybe (ReusableQ Postgres db (WithRewrittenThread PostgresInaccessible CTE.QAnyScope a))) +cteInsertCommandReturning statement mkProjection = + case returning statement mkProjection of PgInsertReturningEmpty -> pure Nothing PgInsertReturning syntax -> Just <$> pgDataModifyingCte syntax diff --git a/beam-postgres.cabal b/beam-postgres.cabal --- a/beam-postgres.cabal +++ b/beam-postgres.cabal @@ -1,5 +1,5 @@ name: beam-postgres -version: 0.6.3.0 +version: 0.6.4.0 synopsis: Connection layer between beam and postgres description: Beam driver for , an advanced open-source RDBMS homepage: https://haskell-beam.github.io/beam/user-guide/backends/beam-postgres @@ -60,7 +60,7 @@ vector >=0.11 && <0.14, network-uri >=2.6 && <2.7, unordered-containers >= 0.2 && <0.3, - tagged >=0.8 && <0.9, + tagged >=0.8 && <0.10, transformers-base >=0.4 && <0.5 default-language: Haskell2010 diff --git a/test/Database/Beam/Postgres/Test/CTE.hs b/test/Database/Beam/Postgres/Test/CTE.hs --- a/test/Database/Beam/Postgres/Test/CTE.hs +++ b/test/Database/Beam/Postgres/Test/CTE.hs @@ -70,6 +70,29 @@ cteDb :: DatabaseSettings Postgres CteDb cteDb = defaultDbSettings +partialCteRowValues + :: Text + -> Int32 + -> SqlInsertValues Postgres + (QExpr Postgres s Text, QExpr Postgres s Int32) +partialCteRowValues value key = + insertData [(val_ value, val_ key)] + +partialCteValueValues + :: Text + -> SqlInsertValues Postgres (QExpr Postgres s Text) +partialCteValueValues value = insertData [val_ value] + +partialCteIdValues + :: Int32 + -> SqlInsertValues Postgres (QExpr Postgres s Int32) +partialCteIdValues key = insertData [val_ key] + +emptyPartialCteRowValues + :: SqlInsertValues Postgres + (QExpr Postgres s Text, QExpr Postgres s Int32) +emptyPartialCteRowValues = SqlInsertValuesEmpty + unitTests :: TestTree unitTests = testGroup "Common table expression tests" [ renderingTests @@ -78,7 +101,8 @@ integrationTests :: IO ByteString -> TestTree integrationTests getConn = testGroup "Common table expression integration tests" - [ testMixedCteBodies getConn + [ testPartialInsertCommandCtes getConn + , testMixedCteBodies getConn , testSideEffectOnlyCtes getConn , testMaterializationExecution getConn , testLiftedWithExecution getConn @@ -95,7 +119,14 @@ renderingTests :: TestTree renderingTests = testGroup "Common table expression rendering tests" - [ testMixedCteRendering + [ testPgInsertOnlyRendering + , testPgInsertOnlyFromAndEmptyRendering + , testCteInsertCommandRendering + , testCteInsertCommandReturningRendering + , testCteInsertCommandNoOps + , testCteInsertCommandReturningZeroProjection + , testLegacyInsertCteCompatibility + , testMixedCteRendering , testMaterializationRendering , testNestedMaterializedCteRendering , testSideEffectOnlyRendering @@ -113,6 +144,147 @@ , testDegreeZeroDataModifyingRendering ] +testPgInsertOnlyRendering :: TestTree +testPgInsertOnlyRendering = testCase "renders partial PostgreSQL inserts with ON CONFLICT" $ do + sql <- requireRenderedStatement . renderInsert $ + Pg.pgInsertOnly + (dbCteRows cteDb) + (\row -> (cteValue row, cteId row)) + (partialCteRowValues "partial" 7) + (Pg.onConflict + (Pg.conflictingFields cteId) + Pg.onConflictDoNothing) + assertBool ("renders only the selected columns in projection order:\n" ++ sql) + ("(\"value\", \"id\") VALUES" `isInfixOf` sql) + assertBool "renders the PostgreSQL conflict action" + ("ON CONFLICT (\"id\") DO NOTHING" `isInfixOf` sql) + +testPgInsertOnlyFromAndEmptyRendering :: TestTree +testPgInsertOnlyFromAndEmptyRendering = testCase "renders partial INSERT FROM and preserves empty inserts" $ do + let fromStatement = Pg.pgInsertOnly + (dbCteRows cteDb) + (\row -> (cteValue row, cteId row)) + (insertFrom $ do + row <- all_ (dbCteRows cteDb) + pure (cteValue row, cteId row)) + Pg.onConflictDefault + emptyStatement = Pg.pgInsertOnly + (dbCteRows cteDb) + (\row -> (cteValue row, cteId row)) + emptyPartialCteRowValues + Pg.onConflictDefault + fromSql <- requireRenderedStatement (renderInsert fromStatement) + assertBool ("renders the selected target columns before INSERT FROM:\n" ++ fromSql) + ("(\"value\", \"id\") SELECT" `isInfixOf` fromSql) + assertEqual "empty projected values still produce no statement" + Nothing + (renderInsert emptyStatement) + +testCteInsertCommandRendering :: TestTree +testCteInsertCommandRendering = testCase "lifts a partial insert command into a side-effect-only CTE" $ do + let sql = renderSelect $ Pg.pgSelectWithTopLevel $ do + Pg.cteInsertCommand $ Pg.pgInsertOnly + (dbCteRows cteDb) + (\row -> (cteValue row, cteId row)) + (partialCteRowValues "side-effect" 8) + Pg.onConflictDefault + pure $ do + guard_ (val_ False) + pure (as_ @Int32 (val_ 0)) + assertBool "renders the command as a top-level CTE" + ("WITH " `isPrefixOf` sql) + assertBool ("retains the partial target projection:\n" ++ sql) + ("INSERT INTO \"cte_rows\"(\"value\", \"id\") VALUES" `isInfixOf` sql) + assertBool "does not add RETURNING to a side-effect-only CTE" + (not (" RETURNING " `isInfixOf` sql)) + +testCteInsertCommandReturningRendering :: TestTree +testCteInsertCommandReturningRendering = testCase "adds RETURNING when lifting a partial insert command" $ do + let sql = renderSelect $ Pg.pgSelectWithTopLevel $ do + inserted <- Pg.cteInsertCommandReturning + (Pg.pgInsertOnly + (dbCteRows cteDb) + (\row -> (cteValue row, cteId row)) + (partialCteRowValues "returning" 9) + (Pg.onConflict + (Pg.conflictingFields cteId) + Pg.onConflictDoNothing)) + id + pure $ case inserted of + Nothing -> do + guard_ (val_ False) + pure (CteRow (val_ 0) (val_ "")) + Just rows -> reuse rows + assertBool "renders the command as a top-level CTE" + ("WITH " `isPrefixOf` sql) + assertBool ("retains selected columns and ON CONFLICT:\n" ++ sql) + ("INSERT INTO \"cte_rows\"(\"value\", \"id\") VALUES" `isInfixOf` sql && + "ON CONFLICT (\"id\") DO NOTHING" `isInfixOf` sql) + assertBool "adds a full-row RETURNING projection" + (" RETURNING \"id\", \"value\"" `isInfixOf` sql) + +testCteInsertCommandNoOps :: TestTree +testCteInsertCommandNoOps = testCase "command-level CTE adapters preserve empty inserts" $ do + let emptyCommand = Pg.pgInsertOnly + (dbCteRows cteDb) + (\row -> (cteValue row, cteId row)) + emptyPartialCteRowValues + Pg.onConflictDefault + sql = renderSelect $ Pg.pgSelectWithTopLevel $ do + Pg.cteInsertCommand emptyCommand + inserted <- Pg.cteInsertCommandReturning emptyCommand id + pure $ case inserted of + Nothing -> pure (as_ @Int32 (val_ 1)) + Just rows -> cteId <$> reuse rows + assertBool ("does not render an empty WITH block:\n" ++ sql) + (not ("WITH " `isPrefixOf` sql)) + assertBool "renders the fallback query after receiving Nothing" + ("SELECT 1" `isPrefixOf` sql) + +testCteInsertCommandReturningZeroProjection :: TestTree +testCteInsertCommandReturningZeroProjection = testCase "command-level returning CTEs preserve zero-field rows" $ do + let sql = renderSelect $ Pg.pgSelectWithTopLevel $ do + inserted <- Pg.cteInsertCommandReturning + (Pg.pgInsertOnly + (dbCteRows cteDb) + (\row -> (cteValue row, cteId row)) + (partialCteRowValues "zero" 10) + Pg.onConflictDefault) + (const (EmptyCte :: EmptyCteT (QExpr Postgres PostgresInaccessible))) + pure $ case inserted of + Nothing -> pure EmptyCte + Just rows -> reuse rows + assertBool "adds the private sentinel to an empty RETURNING projection" + ("RETURNING NULL::boolean" `isInfixOf` sql) + assertBool ("does not expose the private sentinel in the terminal projection:\n" ++ sql) + ("SELECT FROM" `isInfixOf` sql || "SELECT FROM" `isInfixOf` sql) + +testLegacyInsertCteCompatibility :: TestTree +testLegacyInsertCteCompatibility = testCase "legacy insert CTE wrappers match command composition" $ do + let finish inserted = case inserted of + Nothing -> do + guard_ (val_ False) + pure (CteRow (val_ 0) (val_ "")) + Just rows -> reuse rows + legacy = Pg.pgSelectWithTopLevel $ do + inserted <- Pg.cteInsertReturning + (dbCteRows cteDb) + (insertValues [CteRow 11 "legacy"]) + Pg.onConflictDefault + id + pure (finish inserted) + composed = Pg.pgSelectWithTopLevel $ do + inserted <- Pg.cteInsertCommandReturning + (Pg.insert + (dbCteRows cteDb) + (insertValues [CteRow 11 "legacy"]) + Pg.onConflictDefault) + id + pure (finish inserted) + assertEqual "legacy and command-composed SQL" + (renderSelect legacy) + (renderSelect composed) + -- These tests force expressions compiled with deferred type errors in the -- isolated negative-fixture module. Checking fragments of GHC's error ensures -- an unrelated deferred error cannot make a test pass accidentally. @@ -134,6 +306,10 @@ assertPlacementTypeError Negative.invalidNestedIdentityUpdate , testCase "rejects a side-effect-only DELETE inside pgSelectWithNested" $ assertPlacementTypeError Negative.invalidNestedSideEffectDelete + , testCase "rejects a command-level INSERT inside pgSelectWithNested" $ + assertPlacementTypeError Negative.invalidNestedCommandInsert + , testCase "rejects a command-level returning INSERT inside pgSelectWithNested" $ + assertPlacementTypeError Negative.invalidNestedCommandInsertReturning , testCase "placement cannot be bypassed with coerce" $ assertPlacementTypeError Negative.invalidCoercedPlacement , testCase "rejects a recursively self-referencing INSERT CTE" $ @@ -144,6 +320,10 @@ assertDeferredTypeErrorContaining ["ReusableQ"] Negative.invalidReuseSideEffect + , testCase "rejects values which do not match the selected insert columns" $ + assertDeferredInsertTypeErrorContaining + ["Couldn't match", "QExprToField"] + Negative.invalidMismatchedPgInsertOnly ] assertPlacementTypeError :: SqlSelect Postgres a -> Assertion @@ -168,6 +348,24 @@ ("mentions " ++ fragment ++ "\nDeferred error was:\n" ++ message) (fragment `isInfixOf` message) +assertDeferredInsertTypeErrorContaining + :: [String] + -> SqlInsert Postgres table + -> Assertion +assertDeferredInsertTypeErrorContaining expectedFragments statement = do + result <- try (evaluate (maybe 0 length (renderInsert statement))) + case result of + Left (err :: TypeError) -> + let message = show err + in mapM_ (assertFragment message) expectedFragments + Right _ -> + assertFailure "expected the insert to contain a deferred type error" + where + assertFragment message fragment = + assertBool + ("mentions " ++ fragment ++ "\nDeferred error was:\n" ++ message) + (fragment `isInfixOf` message) + -- A single top-level WITH block may freely mix SELECT and data-modifying CTE -- bodies. Besides checking the individual keywords, this guards against -- accidentally nesting a second WITH while combining the syntax fragments. @@ -363,6 +561,129 @@ assertBool (command ++ " does not expose the sentinel") ("SELECT FROM \"cte0\"" `isInfixOf` sql || "SELECT FROM \"cte0\"" `isInfixOf` sql) + +-- Exercise the command-composition path against PostgreSQL itself. Generated +-- and defaulted columns must remain visible to RETURNING even though they are +-- absent from the insert projection, and both conflict actions must retain +-- their normal PostgreSQL semantics. +testPartialInsertCommandCtes :: IO ByteString -> TestTree +testPartialInsertCommandCtes getConn = testCase "partial insert commands preserve defaults and conflicts in CTEs" $ + withTestPostgres "partial_insert_command_ctes" getConn $ \conn -> do + execute_ conn + "CREATE TABLE cte_rows (id SERIAL PRIMARY KEY, value TEXT UNIQUE NOT NULL DEFAULT 'db-default')" + + generated <- runBeamPostgres conn $ runSelectReturningList $ + partialValueReturning "generated" Pg.onConflictDefault + assertEqual "returns an omitted generated identity" + [CteRow 1 "generated"] + generated + + execute_ conn "TRUNCATE TABLE cte_rows RESTART IDENTITY" + defaulted <- runBeamPostgres conn $ runSelectReturningList $ + partialIdReturning 40 Pg.onConflictDefault + assertEqual "returns an omitted database-defaulted value" + [CteRow 40 "db-default"] + defaulted + + execute_ conn "TRUNCATE TABLE cte_rows RESTART IDENTITY" + _ <- runBeamPostgres conn $ runSelectReturningList $ + partialValueReturning "conflict" Pg.onConflictDefault + ignored <- runBeamPostgres conn $ runSelectReturningList $ + partialValueReturning "conflict" $ + Pg.onConflict + (Pg.conflictingFields cteValue) + Pg.onConflictDoNothing + assertEqual "DO NOTHING exposes a real but empty reusable relation" + [] + ignored + + updated <- runBeamPostgres conn $ runSelectReturningList $ + partialValueReturning "conflict" $ + Pg.onConflict + (Pg.conflictingFields cteValue) + (Pg.onConflictUpdateSet $ \target excluded -> + cteId target <-. cteId excluded) + case updated of + [row] -> do + assertEqual "DO UPDATE returns the conflicting value" + "conflict" + (cteValue row) + assertBool "DO UPDATE can use the generated excluded identity" + (cteId row > 1) + rows -> assertFailure ("expected one updated row, got " ++ show rows) + + storedAfterUpdate <- runBeamPostgres conn $ runSelectReturningList $ select $ + all_ (dbCteRows cteDb) + assertEqual "the reusable row agrees with durable table state" + updated + storedAfterUpdate + + execute_ conn "TRUNCATE TABLE cte_rows RESTART IDENTITY" + _ <- runBeamPostgres conn $ runSelectReturningList $ + partialValueReturning "parameter-order" Pg.onConflictDefault + parameterizedUpdate <- runBeamPostgres conn $ runSelectReturningList $ + partialValueReturning "parameter-order" $ + Pg.onConflict + (Pg.conflictingFields cteValue) + (Pg.onConflictUpdateSet $ \target _ -> + cteId target <-. val_ (77 :: Int32)) + assertEqual "parameters remain ordered from insert values into the conflict action" + [CteRow 77 "parameter-order"] + parameterizedUpdate + + execute_ conn "TRUNCATE TABLE cte_rows RESTART IDENTITY" + marker <- runBeamPostgres conn $ runSelectReturningOne $ + Pg.pgSelectWithTopLevel $ do + Pg.cteInsertCommand $ Pg.pgInsertOnly + (dbCteRows cteDb) + cteValue + (partialCteValueValues "side-effect") + Pg.onConflictDefault + pure (pure (as_ @Int32 (val_ 1))) + assertEqual "side-effect-only command CTE executes" + (Just 1) + marker + storedSideEffect <- runBeamPostgres conn $ runSelectReturningList $ select $ + all_ (dbCteRows cteDb) + assertEqual "side-effect-only partial insert uses the generated identity" + [CteRow 1 "side-effect"] + storedSideEffect + +partialValueReturning + :: Text + -> Pg.PgInsertOnConflict CteRowT + -> SqlSelect Postgres (CteRowT Identity) +partialValueReturning value conflict = Pg.pgSelectWithTopLevel $ do + inserted <- Pg.cteInsertCommandReturning + (Pg.pgInsertOnly + (dbCteRows cteDb) + cteValue + (partialCteValueValues value) + conflict) + id + pure $ case inserted of + Nothing -> do + guard_ (val_ False) + pure (CteRow (val_ 0) (val_ "")) + Just rows -> reuse rows + +partialIdReturning + :: Int32 + -> Pg.PgInsertOnConflict CteRowT + -> SqlSelect Postgres (CteRowT Identity) +partialIdReturning key conflict = Pg.pgSelectWithTopLevel $ do + inserted <- Pg.cteInsertCommandReturning + (Pg.pgInsertOnly + (dbCteRows cteDb) + cteId + (partialCteIdValues key) + conflict) + id + pure $ case inserted of + Nothing -> do + guard_ (val_ False) + pure (CteRow (val_ 0) (val_ "")) + Just rows -> reuse rows -- Rendering alone cannot verify PostgreSQL's execution and snapshot semantics. -- This integration case checks both the RETURNING rows and the final table diff --git a/test/Database/Beam/Postgres/Test/CTENegative.hs b/test/Database/Beam/Postgres/Test/CTENegative.hs --- a/test/Database/Beam/Postgres/Test/CTENegative.hs +++ b/test/Database/Beam/Postgres/Test/CTENegative.hs @@ -15,9 +15,12 @@ , invalidNestedEmptyInsert , invalidNestedIdentityUpdate , invalidNestedSideEffectDelete + , invalidNestedCommandInsert + , invalidNestedCommandInsertReturning , invalidCoercedPlacement , invalidRecursiveInsert , invalidReuseSideEffect + , invalidMismatchedPgInsertOnly ) where import qualified Data.Coerce as Coerce @@ -128,6 +131,28 @@ (\row -> negativeCteId row ==. val_ 1) pure $ all_ (negativeCteRows negativeCteDb) +invalidNestedCommandInsert :: SqlSelect Postgres (NegativeCteRowT Identity) +invalidNestedCommandInsert = select $ Pg.pgSelectWithNested $ do + Pg.cteInsertCommand $ Pg.pgInsertOnly + (negativeCteRows negativeCteDb) + id + (insertValues [NegativeCteRow 2 "inserted"]) + Pg.onConflictDefault + pure $ all_ (negativeCteRows negativeCteDb) + +invalidNestedCommandInsertReturning :: SqlSelect Postgres (NegativeCteRowT Identity) +invalidNestedCommandInsertReturning = select $ Pg.pgSelectWithNested $ do + inserted <- Pg.cteInsertCommandReturning + (Pg.pgInsertOnly + (negativeCteRows negativeCteDb) + id + (insertValues [NegativeCteRow 2 "inserted"]) + Pg.onConflictDefault) + id + case inserted of + Nothing -> pure $ all_ (negativeCteRows negativeCteDb) + Just inserted' -> pure (reuse inserted') + -- PgWith has nominal roles and an abstract constructor, so Data.Coerce cannot -- be used to relabel a top-level-only block as nested-safe. invalidCoercedPlacement :: SqlSelect Postgres (NegativeCteRowT Identity) @@ -158,6 +183,17 @@ (NegativeCteRowT (QExpr Postgres CTE.QAnyScope)) impossible = deleted pure (reuse impossible) + +invalidMismatchedPgInsertOnly :: SqlInsert Postgres NegativeCteRowT +invalidMismatchedPgInsertOnly = Pg.pgInsertOnly + (negativeCteRows negativeCteDb) + (\row -> (negativeCteId row, negativeCteValue row)) + singleIdValue + Pg.onConflictDefault + +singleIdValue + :: SqlInsertValues Postgres (QExpr Postgres s Int32) +singleIdValue = insertData [val_ (1 :: Int32)] coercePlacement :: Pg.PgWith NegativeCteDb 'Pg.PgCteTopLevelOnly a diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,8 +1,10 @@ module Main where import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS import Data.Text (unpack) import qualified Data.Text.Lazy as TL +import System.Environment (lookupEnv) import Test.Tasty import qualified TestContainers.Tasty as TC @@ -20,23 +22,32 @@ import qualified Database.PostgreSQL.Simple as Postgres main :: IO () -main = defaultMain $ testGroup "beam-postgres tests" - -- Rendering and compile-negative tests do not need Docker, so keep them - -- outside the Testcontainers resource and available as fast unit tests. - [ CTE.unitTests - , TC.withContainers setupTempPostgresDB $ \getConnStr -> - testGroup "PostgreSQL integration tests" - [ Marshal.tests getConnStr - , CTE.integrationTests getConnStr - , Select.tests getConnStr - , Select.PgNubBy.tests getConnStr - , DataType.tests getConnStr - , Migrate.tests getConnStr - , TempTable.tests getConnStr - , Windowing.tests getConnStr - , Copy.tests getConnStr - ] - ] +main = do + -- CI normally uses Testcontainers. An explicit connection string also makes + -- the suite usable with an externally managed disposable PostgreSQL server. + externalConnStr <- lookupEnv "BEAM_POSTGRES_TEST_CONNSTR" + defaultMain $ testGroup "beam-postgres tests" + -- Rendering and compile-negative tests do not need Docker, so keep them + -- outside the Testcontainers resource and available as fast unit tests. + [ CTE.unitTests + , case externalConnStr of + Just connStr -> integrationTests (pure (BS.pack connStr)) + Nothing -> TC.withContainers setupTempPostgresDB integrationTests + ] + +integrationTests :: IO ByteString -> TestTree +integrationTests getConnStr = + testGroup "PostgreSQL integration tests" + [ Marshal.tests getConnStr + , CTE.integrationTests getConnStr + , Select.tests getConnStr + , Select.PgNubBy.tests getConnStr + , DataType.tests getConnStr + , Migrate.tests getConnStr + , TempTable.tests getConnStr + , Windowing.tests getConnStr + , Copy.tests getConnStr + ] setupTempPostgresDB :: TC.MonadDocker m => m ByteString