Fix runtime SQL error for selectWith without CTEs (#814)

Author: LaurentRDC

beam-core/ChangeLog.md

@@ -1,3 +1,10 @@
+# 0.11.2.0
+
+## Bug fixes
+
+* Fixed an issue where using `selectWith` and no common-table expressions would lead to
+  invalid SQL at runtime.
+
 # 0.11.1.0
 
 ## New features

beam-core/Database/Beam/Query.hs

@@ -121,6 +121,8 @@ import Control.Monad.Identity
 import Control.Monad.Writer
 import Control.Monad.State.Strict
 
+import Data.List.NonEmpty (nonEmpty)
+import qualified Data.List.NonEmpty as NonEmpty
 import Data.Kind (Type)
 import Data.Functor.Const (Const(..))
 import Data.Text (Text)
@@ -158,12 +160,17 @@ selectWith :: forall be db res
               , HasQBuilder be, Projectible be res )
            => With be db (Q be db QBaseScope res) -> SqlSelect be (QExprToIdentity res)
 selectWith (CTE.With mkQ) =
-    let (q, (recursiveness, ctes)) = evalState (runWriterT mkQ) 0
-    in case recursiveness of
-         CTE.Nonrecursive -> SqlSelect (withSyntax ctes
-                                                   (buildSqlQuery "t" q))
-         CTE.Recursive    -> SqlSelect (withRecursiveSyntax ctes
-                                                            (buildSqlQuery "t" q))
+    let (q, (recursiveness, mctes)) = evalState (runWriterT mkQ) 0
+    in case (recursiveness, nonEmpty mctes) of
+         (CTE.Nonrecursive, Just ctes) -> SqlSelect (withSyntax (NonEmpty.toList ctes)
+                                                    (buildSqlQuery "t" q))
+         (CTE.Recursive, Just ctes)    -> SqlSelect (withRecursiveSyntax (NonEmpty.toList ctes)
+                                                    (buildSqlQuery "t" q))
+         -- If there are no subqueries, we don't want to generate
+         -- an empty 'WITH' statement, which would be malformed.
+         -- 
+         -- see: https://github.com/haskell-beam/beam/issues/760
+         (_, Nothing) -> SqlSelect (buildSqlQuery "t" q)
 
 -- | Convenience function to generate a 'SqlSelect' that looks up a table row
 --   given a primary key.

beam-core/beam-core.cabal

@@ -1,5 +1,5 @@
 name:                beam-core
-version:             0.11.1.0
+version:             0.11.2.0
 synopsis:            Type-safe, feature-complete SQL query and manipulation interface for Haskell
 description:         Beam is a Haskell library for type-safe querying and manipulation of SQL databases.
                      Beam is modular and supports various backends. In order to use beam, you will need to use

beam-duckdb/tests/Database/Beam/DuckDB/Test/Query.hs

@@ -12,6 +12,7 @@
 module Database.Beam.DuckDB.Test.Query (tests) where
 
 import Control.Monad (void)
+import Data.Functor ((<&>))
 import Data.Int (Int32)
 import Data.List (nub, nubBy, sort, sortOn)
 import Data.Text (Text)
@@ -130,6 +131,7 @@ tests =
           testGroup
             "CTE"
             [ testCommonTableExpression,
+              testEmptyCommonTableExpression,
               testMultipleCommonTableExpressions,
               testRecursiveCommonTableExpression
             ],
@@ -421,6 +423,29 @@ testCommonTableExpression = testCase "Non-recursive common table expression" $ d
 
       rows @?= [("Alice", 3), ("Bob", 1)]
 
+-- Regression test for https://github.com/haskell-beam/beam/issues/760
+--
+-- Note that this is testing functionality from 'beam-core', but the MockSqlBackend
+-- isn't powerful enough to express this test
+testEmptyCommonTableExpression :: TestTree
+testEmptyCommonTableExpression = testCase "No common table expression in `selectWith` is equivalent to `select`" $ do
+  let users =
+        [ User 1 "Alice" 30,
+          User 2 "Bob" 25,
+          User 3 "Charlie" 35
+        ]
+  withTestDb users [] [] $ \conn ->
+    do
+      rows <-
+        runBeamDuckDB conn
+          $ runSelectReturningList
+            . selectWith
+            . pure
+          $ all_ (_dbUsers testDb)
+            <&> _userName
+
+      rows @?= ["Alice", "Bob", "Charlie"]
+
 testMultipleCommonTableExpressions :: TestTree
 testMultipleCommonTableExpressions = testCase "Multiple common table expressions" $ do
   let users =

beam-postgres/ChangeLog.md

@@ -1,3 +1,10 @@
+# 0.6.2.0
+
+## Bug fixes
+
+* Fixed an issue where using `pgSelectWith` with no common-table expressions
+  would lead to an invalid SQL query at runtime.
+
 # 0.6.1.0
 
 ## Added features

beam-postgres/Database/Beam/Postgres/Full.hs

@@ -71,6 +71,8 @@ import           Control.Monad.Free.Church
 import           Control.Monad.State.Strict (evalState)
 import           Control.Monad.Writer (runWriterT)
 
+import           Data.List.NonEmpty (nonEmpty)
+import qualified Data.List.NonEmpty as NonEmpty
 import           Data.Kind (Type)
 import           Data.Proxy (Proxy(..))
 import qualified Data.Text as T
@@ -289,18 +291,21 @@ lateral_ using mkSubquery = do
 --
 -- @beam-core@ offers 'selectWith' to produce a top-level 'SqlSelect'
 -- but these cannot be turned into 'Q' objects for use within joins.
---
--- The 'pgSelectWith' function is more flexible and indeed
--- 'selectWith' for @beam-postgres@ is equivalent to se
+-- The 'pgSelectWith' function is more flexible.
 pgSelectWith :: forall db s res
               . Projectible Postgres res
              => With Postgres db (Q Postgres db s res) -> Q Postgres db s res
 pgSelectWith (CTE.With mkQ) =
-    let (q, (recursiveness, ctes)) = evalState (runWriterT mkQ) 0
+    let (q, (recursiveness, mctes)) = evalState (runWriterT mkQ) 0
         fromSyntax tblPfx =
-            case recursiveness of
-              CTE.Nonrecursive -> withSyntax ctes (buildSqlQuery tblPfx q)
-              CTE.Recursive -> withRecursiveSyntax ctes (buildSqlQuery tblPfx q)
+            case (recursiveness, nonEmpty mctes) of
+              (CTE.Nonrecursive, Just ctes) -> withSyntax (NonEmpty.toList ctes) (buildSqlQuery tblPfx q)
+              (CTE.Recursive, Just ctes) -> withRecursiveSyntax (NonEmpty.toList ctes) (buildSqlQuery tblPfx q)
+               -- If there are no subqueries, we don't want to generate
+               -- an empty 'WITH' statement, which would be malformed.
+               -- 
+               -- see: https://github.com/haskell-beam/beam/issues/760
+              (_, Nothing) -> buildSqlQuery tblPfx q
     in Q (liftF (QAll (\tblPfx tName ->
                            let (_, names) = mkFieldNames @Postgres @res (qualifiedField tName)
                            in fromTable (PgTableSourceSyntax $
@@ -309,7 +314,7 @@ pgSelectWith (CTE.With mkQ) =
                       (\tName ->
                            let (projection, _) = mkFieldNames @Postgres @res (qualifiedField tName)
                            in projection)
-                      (\_ -> Nothing)
+                      (const Nothing)
                       snd))
 
 -- | By default, Postgres will throw an error when a conflict is detected. This

beam-postgres/beam-postgres.cabal

@@ -1,5 +1,5 @@
 name:                 beam-postgres
-version:              0.6.1.0
+version:              0.6.2.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