beam-postgres 0.6.3.0 → 0.6.4.0

raw patch · 6 files changed

+497/−54 lines, 6 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +9/−0
• Database/Beam/Postgres/Full.hs +99/−33
• beam-postgres.cabal +2/−2
• test/Database/Beam/Postgres/Test/CTE.hs +323/−2
• test/Database/Beam/Postgres/Test/CTENegative.hs +36/−0
• test/Main.hs +28/−17

@@ -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

@@ -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

@@ -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 <https://www.postgresql.org/ PostgreSQL>, 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

@@ -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

@@ -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

@@ -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