beam-postgres 0.5.6.1 → 0.6.0.0

raw patch · 11 files changed

+301/−46 lines, 11 filesdep ~beam-coredep ~beam-migratedep ~timePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: beam-core, beam-migrate, time

API changes (from Hackage documentation)

Files

• ChangeLog.md +27/−0
• Database/Beam/Postgres/Connection.hs +18/−19
• Database/Beam/Postgres/Migrate.hs +7/−1
• Database/Beam/Postgres/PgSpecific.hs +1/−4
• Database/Beam/Postgres/Syntax.hs +1/−0
• beam-postgres.cabal +5/−4
• test/Database/Beam/Postgres/Test/DataTypes.hs +8/−8
• test/Database/Beam/Postgres/Test/Marshal.hs +3/−3
• test/Database/Beam/Postgres/Test/Select.hs +2/−1
• test/Database/Beam/Postgres/Test/Windowing.hs +221/−0
• test/Main.hs +8/−6

@@ -1,3 +1,30 @@+# 0.6.0.0++## Interface changes++* Removed `week_` from `Database.Beam.Postgres.PgSpecific`. The same+  functionality is now available in `beam-core` as a backend-agnostic+  `week_` extract field; import it from `Database.Beam.Query.Extract` (or+  re-exported through `Database.Beam`) instead.+* Replaced the single `BeamSqlBackendHasSerial Postgres` instance with three+  width-specific instances `BeamSqlBackendHasSerial Int16/Int32/Int64+  Postgres`, mapping respectively to `smallserial`, `serial`, and+  `bigserial`. Existing code using `genericSerial` for a `SqlSerial Int32`+  column continues to work; other widths are now also supported (#534).++## Added features++* Implemented the new `runInsertReturningListWith` /+  `runUpdateReturningListWith` / `runDeleteReturningListWith` class methods+  on the `Pg` monad. These let callers project a subset of columns from the+  affected rows of an `INSERT` / `UPDATE` / `DELETE ... RETURNING` (#801).+* Implemented `weekField` for `PgExtractFieldSyntax`, supporting the new+  backend-agnostic `week_` extract field from `beam-core`.++## Updated dependencies++* Bumped the lower bound on `beam-core` to `0.11`.+ # 0.5.6.1  ## Bug fixes

@@ -26,13 +26,13 @@   , postgresUriSyntax ) where  import           Control.Exception (SomeException(..), throwIO)-import           Data.IORef (newIORef, readIORef, writeIORef)-import           Data.Vector (Vector)-import qualified Data.Vector as V import           Control.Monad.Base (MonadBase(..)) import           Control.Monad.Free.Church import           Control.Monad.IO.Class import           Control.Monad.Trans.Control (MonadBaseControl(..))+import           Data.IORef (newIORef, readIORef, writeIORef)+import           Data.Vector (Vector)+import qualified Data.Vector as V  import           Database.Beam hiding (runDelete, runUpdate, runInsert, insert) import           Database.Beam.Backend.SQL.BeamExtensions@@ -408,12 +408,11 @@           in collectM id  instance MonadBeamInsertReturning Postgres Pg where-    runInsertReturningList i = do-        let insertReturningCmd' = i `returning`-              changeBeamRep (\(Columnar' (QExpr s) :: Columnar' (QExpr Postgres PostgresInaccessible) ty) ->-                Columnar' (QExpr s) :: Columnar' (QExpr Postgres ()) ty)--        -- Make savepoint+    runInsertReturningListWith i mkProjection = do+        let pgProj tbl = mkProjection (changeBeamRep+              (\(Columnar' (QExpr s) :: Columnar' (QExpr Postgres PostgresInaccessible) ty) ->+                Columnar' (QExpr s) :: Columnar' (QExpr Postgres ()) ty) tbl)+            insertReturningCmd' = i `returning` pgProj         case insertReturningCmd' of           PgInsertReturningEmpty ->             pure []@@ -421,11 +420,11 @@             runReturningList (PgCommandSyntax PgCommandTypeDataUpdateReturning insertReturningCmd)  instance MonadBeamUpdateReturning Postgres Pg where-    runUpdateReturningList u = do-        let updateReturningCmd' = u `returning`-              changeBeamRep (\(Columnar' (QExpr s) :: Columnar' (QExpr Postgres PostgresInaccessible) ty) ->-                Columnar' (QExpr s) :: Columnar' (QExpr Postgres ()) ty)-+    runUpdateReturningListWith u mkProjection = do+        let pgProj tbl = mkProjection (changeBeamRep+              (\(Columnar' (QExpr s) :: Columnar' (QExpr Postgres PostgresInaccessible) ty) ->+                Columnar' (QExpr s) :: Columnar' (QExpr Postgres ()) ty) tbl)+            updateReturningCmd' = u `returning` pgProj         case updateReturningCmd' of           PgUpdateReturningEmpty ->             pure []@@ -433,9 +432,9 @@             runReturningList (PgCommandSyntax PgCommandTypeDataUpdateReturning updateReturningCmd)  instance MonadBeamDeleteReturning Postgres Pg where-    runDeleteReturningList d = do-        let PgDeleteReturning deleteReturningCmd = d `returning`-              changeBeamRep (\(Columnar' (QExpr s) :: Columnar' (QExpr Postgres PostgresInaccessible) ty) ->-                Columnar' (QExpr s) :: Columnar' (QExpr Postgres ()) ty)-+    runDeleteReturningListWith d mkProjection = do+        let pgProj tbl = mkProjection (changeBeamRep+              (\(Columnar' (QExpr s) :: Columnar' (QExpr Postgres PostgresInaccessible) ty) ->+                Columnar' (QExpr s) :: Columnar' (QExpr Postgres ()) ty) tbl)+            PgDeleteReturning deleteReturningCmd = d `returning` pgProj         runReturningList (PgCommandSyntax PgCommandTypeDataUpdateReturning deleteReturningCmd)

@@ -598,5 +598,11 @@   field' _ _ nm ty _ collation constraints PgHasDefault =     Db.field' (Proxy @'True) (Proxy @'False) nm ty Nothing collation constraints -instance BeamSqlBackendHasSerial Postgres where+instance BeamSqlBackendHasSerial Int16 Postgres where+  genericSerial nm = Db.field nm smallserial PgHasDefault++instance BeamSqlBackendHasSerial Int32 Postgres where   genericSerial nm = Db.field nm serial PgHasDefault++instance BeamSqlBackendHasSerial Int64 Postgres where+  genericSerial nm = Db.field nm bigserial PgHasDefault

@@ -111,7 +111,7 @@      -- * Postgres @EXTRACT@ fields   , century_, decade_, dow_, doy_, epoch_, isodow_, isoyear_-  , microseconds_, milliseconds_, millennium_, quarter_, week_+  , microseconds_, milliseconds_, millennium_, quarter_      -- ** Postgres functions and aggregates   , pgBoolOr, pgBoolAnd, pgStringAgg, pgStringAggOver@@ -1674,9 +1674,6 @@  quarter_ :: HasSqlDate tgt => ExtractField Postgres tgt Int32 quarter_ = ExtractField (PgExtractFieldSyntax (emit "QUARTER"))--week_ :: HasSqlDate tgt => ExtractField Postgres tgt Int32-week_ = ExtractField (PgExtractFieldSyntax (emit "WEEK"))  -- $full-text-search --

@@ -798,6 +798,7 @@   minutesField = PgExtractFieldSyntax (emit "MINUTE")   hourField    = PgExtractFieldSyntax (emit "HOUR")   dayField     = PgExtractFieldSyntax (emit "DAY")+  weekField    = PgExtractFieldSyntax (emit "WEEK")   monthField   = PgExtractFieldSyntax (emit "MONTH")   yearField    = PgExtractFieldSyntax (emit "YEAR") 

@@ -1,5 +1,5 @@ name:                 beam-postgres-version:              0.5.6.1+version:              0.6.0.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@@ -35,8 +35,8 @@                       Database.Beam.Postgres.Types    build-depends:      base                 >=4.11 && <5.0,-                      beam-core            >=0.10 && <0.11,-                      beam-migrate         >=0.5.4.0 && <0.6,+                      beam-core            >=0.11 && <0.12,+                      beam-migrate         >=0.6 && <0.7,                        postgresql-libpq     >=0.8  && <0.12,                       postgresql-simple    >=0.5  && <0.8,@@ -84,7 +84,8 @@                  Database.Beam.Postgres.Test.Select,                  Database.Beam.Postgres.Test.DataTypes,                  Database.Beam.Postgres.Test.Migrate,-                 Database.Beam.Postgres.Test.TempTable+                 Database.Beam.Postgres.Test.TempTable,+                 Database.Beam.Postgres.Test.Windowing   build-depends:     aeson,     base,

@@ -3,10 +3,10 @@ module Database.Beam.Postgres.Test.DataTypes where  import Database.Beam+import Database.Beam.Backend.SQL.BeamExtensions+import Database.Beam.Migrate import Database.Beam.Postgres import Database.Beam.Postgres.Test-import Database.Beam.Migrate-import Database.Beam.Backend.SQL.BeamExtensions  import Control.Exception (SomeException(..), handle) @@ -141,15 +141,15 @@ -- | Regression test for <https://github.com/haskell-beam/beam/issues/700> errorOnLiteralDoubles :: IO ByteString -> TestTree errorOnLiteralDoubles pgConn =-    testCase "Literal `Double`s are correctly specified as SQL `DOUBLE` (#700)" $ +    testCase "Literal `Double`s are correctly specified as SQL `DOUBLE` (#700)" $     withTestPostgres "db_failures" pgConn $ \conn -> do-      results <- runBeamPostgres conn $ -        runSelectReturningList $ -          select $ +      results <- runBeamPostgres conn $+        runSelectReturningList $+          select $             query-      +       results @?= [(99 :: Int32, 1.0 :: Double)]-    +     where       -- We need to provide a db for type-checking, but it will not be used       query :: Q Postgres RealDb s (QExpr Postgres s Int32, QExpr Postgres s Double)

@@ -52,7 +52,7 @@                         (PgPoint (max x1 x2) (max y1 y2)))  arrayGen :: Hedgehog.Gen a -> Hedgehog.Gen (Vector.Vector a)-arrayGen = fmap Vector.fromList +arrayGen = fmap Vector.fromList          . Gen.list (Range.linear 0 5) -- small arrays == quick tests  boxCmp :: PgBox -> PgBox -> Bool@@ -100,8 +100,8 @@      -- Arrays     ---    -- Testing lots of element types for arrays is important, because -    -- the mapping between array Oid and element Oid is not type +    -- Testing lots of element types for arrays is important, because+    -- the mapping between array Oid and element Oid is not type     -- safe, and hence error-prone.     , marshalTest (arrayGen textGen) postgresConn     , marshalTest (arrayGen (Gen.double (Range.exponentialFloat 0 1e40))) postgresConn

@@ -5,6 +5,7 @@  import           Data.Aeson import           Data.ByteString (ByteString)+import           Data.List.NonEmpty (NonEmpty(..)) import           Data.Int import           Data.List (sort) import qualified Data.Text as T@@ -164,7 +165,7 @@         pgCreateExtension @UuidOssp       let ext = getPgExtension $ _uuidOssp $ unCheckDatabase db       runSelectReturningList $ select $ do-        v <- values_ [val_ nil]+        v <- values_ (val_ nil :| [])         return $ pgUuidGenerateV5 ext v ""     assertEqual "result" [V5.generateNamed nil []] result 

@@ -0,0 +1,221 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE StandaloneDeriving #-}++module Database.Beam.Postgres.Test.Windowing (tests) where++import Database.Beam+import Database.Beam.Backend.SQL.BeamExtensions+import Database.Beam.Migrate+import Database.Beam.Migrate.Simple (autoMigrate)+import Database.Beam.Postgres+import Database.Beam.Postgres.Migrate (migrationBackend)+import Database.Beam.Postgres.Test++import Control.Exception (SomeException (..), handle)++import Data.ByteString (ByteString)+import Data.Int+import Data.Text (Text)++import Control.Monad (void)+import Test.Tasty+import Test.Tasty.HUnit++tests :: IO ByteString -> TestTree+tests postgresConn =+    testGroup+        "Windowing unit tests"+        [ testLead1 postgresConn+        , testLag1 postgresConn+        , testLead postgresConn+        , testLag postgresConn+        , testLeadWithDefault postgresConn+        , testLagWithDefault postgresConn+        ]++testLead1 :: IO ByteString -> TestTree+testLead1 = testCase "lead1_" . windowingQueryTest query expectation+  where+    query =+        withWindow_+            ( \Person{name} ->+                frame_+                    noPartition_+                    (orderPartitionBy_ (asc_ name))+                    noBounds_+            )+            ( \Person{name} w ->+                (name, lead1_ name `over_` w)+            )+            (all_ $ persons db)+    expectation = [("Alice", Just "Bob"), ("Bob", Just "Claire"), ("Claire", Nothing)]++testLag1 :: IO ByteString -> TestTree+testLag1 = testCase "lag1_" . windowingQueryTest query expectation+  where+    query =+        withWindow_+            ( \Person{name} ->+                frame_+                    noPartition_+                    (orderPartitionBy_ (asc_ name))+                    noBounds_+            )+            ( \Person{name} w ->+                (name, lag1_ name `over_` w)+            )+            (all_ $ persons db)+    expectation = [("Alice", Nothing), ("Bob", Just "Alice"), ("Claire", Just "Bob")]++testLead :: IO ByteString -> TestTree+testLead getConnStr =+    testGroup+        "lead_"+        [ testCase "n=1" $ windowingQueryTest (query 1) [("Alice", Just "Bob"), ("Bob", Just "Claire"), ("Claire", Nothing)] getConnStr+        , testCase "n=2" $ windowingQueryTest (query 2) [("Alice", Just "Claire"), ("Bob", Nothing), ("Claire", Nothing)] getConnStr+        ]+  where+    query n =+        withWindow_+            ( \Person{name} ->+                frame_+                    noPartition_+                    (orderPartitionBy_ (asc_ name))+                    noBounds_+            )+            ( \Person{name} w ->+                (name, lead_ name (val_ (n :: Int32)) `over_` w)+            )+            (all_ $ persons db)+    expectation1 = []++testLag :: IO ByteString -> TestTree+testLag getConnStr =+    testGroup+        "lag_"+        [ testCase "n=1" $ windowingQueryTest (query 1) [("Alice", Nothing), ("Bob", Just "Alice"), ("Claire", Just "Bob")] getConnStr+        , testCase "n=2" $ windowingQueryTest (query 2) [("Alice", Nothing), ("Bob", Nothing), ("Claire", Just "Alice")] getConnStr+        ]+  where+    query n =+        withWindow_+            ( \Person{name} ->+                frame_+                    noPartition_+                    (orderPartitionBy_ (asc_ name))+                    noBounds_+            )+            ( \Person{name} w ->+                (name, lag_ name (val_ (n :: Int32)) `over_` w)+            )+            (all_ $ persons db)+    expectation = []+++testLeadWithDefault :: IO ByteString -> TestTree+testLeadWithDefault getConnStr =+    testGroup+        "leadWithDefault_"+        [ testCase "n=1" $ windowingQueryTest (query 1 "default") [("Alice", "Bob"), ("Bob", "Claire"), ("Claire", "default")] getConnStr+        , testCase "n=2" $ windowingQueryTest (query 2 "default") [("Alice", "Claire"), ("Bob", "default"), ("Claire", "default")] getConnStr+        ]+  where+    query n def =+        withWindow_+            ( \Person{name} ->+                frame_+                    noPartition_+                    (orderPartitionBy_ (asc_ name))+                    noBounds_+            )+            ( \Person{name} w ->+                (name, leadWithDefault_ name (val_ (n :: Int32)) (val_ def) `over_` w)+            )+            (all_ $ persons db)+    expectation1 = []+++testLagWithDefault :: IO ByteString -> TestTree+testLagWithDefault getConnStr =+    testGroup+        "lagWithDefault_"+        [ testCase "n=1" $ windowingQueryTest (query 1 "default") [("Alice", "default"), ("Bob", "Alice"), ("Claire", "Bob")] getConnStr+        , testCase "n=2" $ windowingQueryTest (query 2 "default") [("Alice", "default"), ("Bob", "default"), ("Claire", "Alice")] getConnStr+        ]+  where+    query n def =+        withWindow_+            ( \Person{name} ->+                frame_+                    noPartition_+                    (orderPartitionBy_ (asc_ name))+                    noBounds_+            )+            ( \Person{name} w ->+                (name, lagWithDefault_ name (val_ (n :: Int32)) (val_ def) `over_` w)+            )+            (all_ $ persons db)+    expectation = []++++data PersonT f = Person+    { name :: C f Text+    }+    deriving (Generic)++type Person = PersonT Identity++type PersonExpr s = PersonT (QExpr Postgres s)++deriving instance Show Person+deriving instance Eq Person++instance Beamable PersonT++instance Table PersonT where+    data PrimaryKey PersonT f = PersonKey (C f Text)+        deriving stock (Generic)+        deriving anyclass (Beamable)++    primaryKey Person{name} = PersonKey name++data Db f = Db+    { persons :: f (TableEntity PersonT)+    }+    deriving (Generic)++instance Database Postgres Db++db :: DatabaseSettings Postgres Db+db = defaultDbSettings++windowingQueryTest ::+    (Eq a, Show a, Eq b, Show b, FromBackendRow Postgres a, FromBackendRow Postgres b) =>+    Q Postgres Db QBaseScope (QExpr Postgres s a, QExpr Postgres s b) ->+    [(a, b)] ->+    IO ByteString ->+    Assertion+windowingQueryTest query expectation getConnStr =+    withTestPostgres "db_windowing_psql" getConnStr $+        \conn -> do+            prepareTable conn+            results <-+                runBeamPostgres conn $+                    runSelectReturningList $+                        select query++            assertEqual "Unexpected" expectation results++prepareTable :: Connection -> IO ()+prepareTable conn =+    runBeamPostgres conn $ do+        void $ autoMigrate migrationBackend (defaultMigratableDbSettings @Postgres @Db)+        runInsert $+            insert (persons db) $+                insertValues+                    [ Person "Alice"+                    , Person "Bob"+                    , Person "Claire"+                    ]

@@ -12,19 +12,21 @@ import qualified Database.Beam.Postgres.Test.DataTypes as DataType import qualified Database.Beam.Postgres.Test.Migrate as Migrate import qualified Database.Beam.Postgres.Test.TempTable as TempTable+import qualified Database.Beam.Postgres.Test.Windowing as Windowing import Database.PostgreSQL.Simple ( ConnectInfo(..), defaultConnectInfo ) import qualified Database.PostgreSQL.Simple as Postgres  main :: IO ()-main = defaultMain -     $ TC.withContainers setupTempPostgresDB -     $ \getConnStr -> +main = defaultMain+     $ TC.withContainers setupTempPostgresDB+     $ \getConnStr ->         testGroup "beam-postgres tests"           [ Marshal.tests getConnStr           , Select.tests getConnStr           , DataType.tests getConnStr           , Migrate.tests getConnStr           , TempTable.tests getConnStr+          , Windowing.tests getConnStr           ]  @@ -41,10 +43,10 @@                        , ("POSTGRES_DB", db)                        ]         TC.& TC.setWaitingFor (TC.waitForLogLine TC.Stderr ("database system is ready to accept connections" `TL.isInfixOf`))-    -    pure $ Postgres.postgreSQLConnectionString ++    pure $ Postgres.postgreSQLConnectionString                    ( defaultConnectInfo { connectHost     = "localhost"-                                        , connectUser     = unpack user +                                        , connectUser     = unpack user                                         , connectPassword = unpack password                                         , connectDatabase = unpack db                                         , connectPort     = fromIntegral $ TC.containerPort timescaleContainer 5432