beam-postgres 0.4.0.0 → 0.5.0.0

raw patch · 21 files changed

+707/−359 lines, 21 filesdep +tmp-postgresdep −directorydep −filepathdep −processdep ~aesondep ~basedep ~beam-corePVP ok

version bump matches the API change (PVP)

Dependencies added: tmp-postgres

Dependencies removed: directory, filepath, process, temporary

Dependency ranges changed: aeson, base, beam-core, beam-migrate, hashable, haskell-src-exts, vector

API changes (from Hackage documentation)

Files

• ChangeLog.md +30/−0
• Database/Beam/Postgres.hs +8/−3
• Database/Beam/Postgres/Conduit.hs +13/−11
• Database/Beam/Postgres/Connection.hs +61/−24
• Database/Beam/Postgres/Debug.hs +3/−5
• Database/Beam/Postgres/Extensions.hs +1/−1
• Database/Beam/Postgres/Extensions/Internal.hs +17/−0
• Database/Beam/Postgres/Extensions/UuidOssp.hs +63/−0
• Database/Beam/Postgres/Full.hs +88/−133
• Database/Beam/Postgres/Migrate.hs +16/−6
• Database/Beam/Postgres/PgCrypto.hs +4/−12
• Database/Beam/Postgres/PgSpecific.hs +155/−37
• Database/Beam/Postgres/Syntax.hs +10/−4
• Database/Beam/Postgres/Types.hs +49/−15
• beam-postgres.cabal +29/−13
• test/Database/Beam/Postgres/Test.hs +8/−44
• test/Database/Beam/Postgres/Test/DataTypes.hs +11/−11
• test/Database/Beam/Postgres/Test/Marshal.hs +7/−7
• test/Database/Beam/Postgres/Test/Migrate.hs +26/−0
• test/Database/Beam/Postgres/Test/Select.hs +95/−26
• test/Main.hs +13/−7

@@ -1,3 +1,33 @@+# 0.5.0.0++## Interface changes++ * Removed instances for machine-dependent ambiguous integer types `Int` and `Word`+ * Fixed types for some functions that only work with `jsonb` and not `json`++## Added features++ * Support for `in_` on row values+ * Various Postgres regex functions+ * Expose `fromPgIntegral` and `fromPgScientificOrIntegral`+ * Add `liftIOWithHandle :: (Connection -> IO a) -> Pg a`+ * Add `getDbConstraintsForSchemas` to get constraints without relying on the state of the connection+ * Poly-kinded instances for `Data.Tagged.Tagged`+ * Add `HasDefaultDatatype` for `UTCTime`+ * Support for specifically-sized `SqlSerial` integers (`smallserial`, `serial`, `bigserial`)+ * Predicate detection for extensions+ * `pgArrayToJson` for `array_to_json`+ * Extension definition and all functions provided by `uuid-ossp`+ * GHC 8.8 support++## Bug fixes++ * Only detect primary keys of tables in visible schemas+ * Fix emitting of `DECIMAL` type+ * Report JSON correct decoding errors instead of throwing `UnexpectedNull`++# 0.4.0.0+ # 0.3.2.0  Add `Semigroup` instances to prepare for GHC 8.4 and Stackage nightly

@@ -15,11 +15,11 @@ -- <https://www.postgresql.org/docs/current/static/index.html behavior>. -- -- For examples on how to use @beam-postgres@ usage, see--- <http://tathougies.github.io/beam/user-guide/backends/beam-postgres/ its manual>.+-- <https://haskell-beam.github.io/beam/user-guide/backends/beam-postgres/ its manual>.  module Database.Beam.Postgres   (  -- * Beam Postgres backend-    Postgres(..), Pg+    Postgres(..), Pg, liftIOWithHandle      -- ** Postgres syntax   , PgCommandSyntax, PgSyntax@@ -48,6 +48,10 @@   , pgCreateExtension, pgDropExtension   , getPgExtension +    -- ** Utilities for defining custom instances+  , fromPgIntegral+  , fromPgScientificOrIntegral+     -- ** Debug support    , PgDebugStmt@@ -67,7 +71,8 @@   ) where  import Database.Beam.Postgres.Connection-import Database.Beam.Postgres.Syntax hiding (PostgresInaccessible)+import Database.Beam.Postgres.Full () -- for BeamHasInsertOnConflict instance+import Database.Beam.Postgres.Syntax import Database.Beam.Postgres.Types import Database.Beam.Postgres.PgSpecific import Database.Beam.Postgres.Migrate ( tsquery, tsvector, text, bytea, unboundedArray

@@ -29,6 +29,8 @@ import           Data.Semigroup #endif +import qualified Control.Monad.Fail as Fail+ #if MIN_VERSION_conduit(1,3,0) #define CONDUIT_TRANSFORMER C.ConduitT #else@@ -38,7 +40,7 @@ -- * @SELECT@  -- | Run a PostgreSQL @SELECT@ statement in any 'MonadIO'.-runSelect :: ( MonadIO m,  MonadBaseControl IO m, FromBackendRow Postgres a )+runSelect :: ( MonadIO m, Fail.MonadFail m, MonadBaseControl IO m, FromBackendRow Postgres a )           => Pg.Connection -> SqlSelect Postgres a           -> (CONDUIT_TRANSFORMER () a m () -> m b) -> m b runSelect conn (SqlSelect (PgSelectSyntax syntax)) withSrc =@@ -56,7 +58,7 @@  -- | Run a PostgreSQL @INSERT ... RETURNING ...@ statement in any 'MonadIO' and -- get a 'C.Source' of the newly inserted rows.-runInsertReturning :: ( MonadIO m,  MonadBaseControl IO m, FromBackendRow Postgres a )+runInsertReturning :: ( MonadIO m, Fail.MonadFail m, MonadBaseControl IO m, FromBackendRow Postgres a )                    => Pg.Connection                    -> PgInsertReturning a                    -> (CONDUIT_TRANSFORMER () a m () -> m b)@@ -77,7 +79,7 @@  -- | Run a PostgreSQL @UPDATE ... RETURNING ...@ statement in any 'MonadIO' and -- get a 'C.Source' of the newly updated rows.-runUpdateReturning :: ( MonadIO m, MonadBaseControl IO m, FromBackendRow Postgres a)+runUpdateReturning :: ( MonadIO m, Fail.MonadFail m, MonadBaseControl IO m, FromBackendRow Postgres a)                    => Pg.Connection                    -> PgUpdateReturning a                    -> (CONDUIT_TRANSFORMER () a m () -> m b)@@ -98,7 +100,7 @@  -- | Run a PostgreSQl @DELETE ... RETURNING ...@ statement in any -- 'MonadIO' and get a 'C.Source' of the deleted rows.-runDeleteReturning :: ( MonadIO m, MonadBaseControl IO m, FromBackendRow Postgres a )+runDeleteReturning :: ( MonadIO m, Fail.MonadFail m, MonadBaseControl IO m, FromBackendRow Postgres a )                    => Pg.Connection -> PgDeleteReturning a                    -> (CONDUIT_TRANSFORMER () a m () -> m b) -> m b runDeleteReturning conn (PgDeleteReturning d) withSrc =@@ -115,7 +117,7 @@  -- | Runs any query that returns a set of values runQueryReturning-  :: ( MonadIO m, MonadBaseControl IO m, Functor m, FromBackendRow Postgres r )+  :: ( MonadIO m, Fail.MonadFail m, MonadBaseControl IO m, Functor m, FromBackendRow Postgres r )   => Pg.Connection -> PgSyntax   -> (CONDUIT_TRANSFORMER () r m () -> m b)   -> m b@@ -130,10 +132,10 @@       singleRowModeSet <- liftIO (Pg.withConnection conn Pg.setSingleRowMode)       if singleRowModeSet          then withSrc (streamResults Nothing) `finally` gracefulShutdown-         else fail "Could not enable single row mode"+         else Fail.fail "Could not enable single row mode"     else do       errMsg <- fromMaybe "No libpq error provided" <$> liftIO (Pg.withConnection conn Pg.errorMessage)-      fail (show errMsg)+      Fail.fail (show errMsg)    where     streamResults fields = do@@ -152,15 +154,15 @@                      do C.yield parsedRow'                         streamResults (Just fields')             Pg.TuplesOk -> liftIO (Pg.withConnection conn finishQuery)-            Pg.EmptyQuery -> fail "No query"+            Pg.EmptyQuery -> Fail.fail "No query"             Pg.CommandOk -> pure ()             _ -> do errMsg <- liftIO (Pg.resultErrorMessage row)-                    fail ("Postgres error: " <> show errMsg)+                    Fail.fail ("Postgres error: " <> show errMsg)      bailEarly row errorString = do       Pg.unsafeFreeResult row       Pg.withConnection conn $ cancelQuery-      fail errorString+      Fail.fail errorString      cancelQuery conn' = do       cancel <- Pg.getCancel conn'@@ -170,7 +172,7 @@           res <- Pg.cancel cancel'           case res of             Right () -> liftIO (finishQuery conn')-            Left err -> fail ("Could not cancel: " <> show err)+            Left err -> Fail.fail ("Could not cancel: " <> show err)      finishQuery conn' = do       nextRow <- Pg.getResult conn'

@@ -15,6 +15,8 @@ module Database.Beam.Postgres.Connection   ( Pg(..), PgF(..) +  , liftIOWithHandle+   , runBeamPostgres, runBeamPostgresDebug    , pgRenderSyntax, runPgRowReader, getFields@@ -32,7 +34,6 @@ import           Database.Beam.Backend.SQL.Row ( FromBackendRowF(..), FromBackendRowM(..)                                                , BeamRowReadError(..), ColumnParseError(..) ) import           Database.Beam.Backend.URI-import           Database.Beam.Query.Types (QGenExpr(..)) import           Database.Beam.Schema.Tables  import           Database.Beam.Postgres.Syntax@@ -53,7 +54,6 @@  import           Control.Monad.Reader import           Control.Monad.State-import           Control.Monad.Fail (MonadFail) import qualified Control.Monad.Fail as Fail  import           Data.ByteString (ByteString)@@ -64,11 +64,7 @@ import           Data.String import qualified Data.Text as T import           Data.Text.Encoding (decodeUtf8)-#if MIN_VERSION_base(4,12,0) import           Data.Typeable (cast)-#else-import           Data.Typeable (cast, typeOf)-#endif #if !MIN_VERSION_base(4, 11, 0) import           Data.Semigroup #endif@@ -188,7 +184,8 @@       step (PgLiftIO io next) = io >>= next       step (PgLiftWithHandle withConn next) = withConn conn >>= next       step (PgFetchNext next) = next Nothing-      step (PgRunReturning (PgCommandSyntax PgCommandTypeQuery syntax)+      step (PgRunReturning CursorBatching+                           (PgCommandSyntax PgCommandTypeQuery syntax)                            (mkProcess :: Pg (Maybe x) -> Pg a')                            next) =         do query <- pgRenderSyntax conn syntax@@ -205,31 +202,39 @@                     columnCount = fromIntegral $ valuesNeeded (Proxy @Postgres) (Proxy @x)                in Pg.foldWith_ (Pg.RP (put columnCount >> ask)) conn (Pg.Query query) (PgStreamContinue nextStream) runConsumer >>= finishUp-      step (PgRunReturning (PgCommandSyntax PgCommandTypeDataUpdateReturning syntax) mkProcess next) =+      step (PgRunReturning AtOnce+                           (PgCommandSyntax PgCommandTypeQuery syntax)+                           (mkProcess :: Pg (Maybe x) -> Pg a')+                           next) =+        renderExecReturningList "No tuples returned to Postgres query" syntax mkProcess next+      step (PgRunReturning _ (PgCommandSyntax PgCommandTypeDataUpdateReturning syntax) mkProcess next) =+        renderExecReturningList "No tuples returned to Postgres update/insert returning" syntax mkProcess next+      step (PgRunReturning _ (PgCommandSyntax _ syntax) mkProcess next) =         do query <- pgRenderSyntax conn syntax            dbg (T.unpack (decodeUtf8 query))+           _ <- Pg.execute_ conn (Pg.Query query) +           let Pg process = mkProcess (Pg (liftF (PgFetchNext id)))+           runF process next stepReturningNone++      renderExecReturningList :: (FromBackendRow Postgres x) => _ -> PgSyntax -> (Pg (Maybe x) -> Pg a') -> _ -> _+      renderExecReturningList errMsg syntax mkProcess next =+        do query <- pgRenderSyntax conn syntax+           dbg (T.unpack (decodeUtf8 query))+            res <- Pg.exec conn query            sts <- Pg.resultStatus res            case sts of              Pg.TuplesOk -> do                let Pg process = mkProcess (Pg (liftF (PgFetchNext id)))                runF process (\x _ -> Pg.unsafeFreeResult res >> next x) (stepReturningList res) 0-             _ -> Pg.throwResultError "No tuples returned to Postgres update/insert returning"-                                      res sts-      step (PgRunReturning (PgCommandSyntax _ syntax) mkProcess next) =-        do query <- pgRenderSyntax conn syntax-           dbg (T.unpack (decodeUtf8 query))-           _ <- Pg.execute_ conn (Pg.Query query)--           let Pg process = mkProcess (Pg (liftF (PgFetchNext id)))-           runF process next stepReturningNone+             _ -> Pg.throwResultError errMsg res sts        stepReturningNone :: forall a. PgF (IO (Either BeamRowReadError a)) -> IO (Either BeamRowReadError a)       stepReturningNone (PgLiftIO action' next) = action' >>= next       stepReturningNone (PgLiftWithHandle withConn next) = withConn conn >>= next       stepReturningNone (PgFetchNext next) = next Nothing-      stepReturningNone (PgRunReturning _ _ _) = pure (Left (BeamRowReadError Nothing (ColumnErrorInternal  "Nested queries not allowed")))+      stepReturningNone (PgRunReturning {}) = pure (Left (BeamRowReadError Nothing (ColumnErrorInternal  "Nested queries not allowed")))        stepReturningList :: forall a. Pg.Result -> PgF (CInt -> IO (Either BeamRowReadError a)) -> CInt -> IO (Either BeamRowReadError a)       stepReturningList _   (PgLiftIO action' next) rowIdx = action' >>= \x -> next x rowIdx@@ -241,7 +246,7 @@              else runPgRowReader conn (Pg.Row rowIdx) res fields fromBackendRow >>= \case                     Left err -> pure (Left err)                     Right r -> next (Just r) (rowIdx + 1)-      stepReturningList _   (PgRunReturning _ _ _) _ = pure (Left (BeamRowReadError Nothing (ColumnErrorInternal "Nested queries not allowed")))+      stepReturningList _   (PgRunReturning {}) _ = pure (Left (BeamRowReadError Nothing (ColumnErrorInternal "Nested queries not allowed")))       stepReturningList _   (PgLiftWithHandle {}) _ = pure (Left (BeamRowReadError Nothing (ColumnErrorInternal "Nested queries not allowed")))        finishProcess :: forall a. a -> Maybe PgI.Row -> IO (PgStream a)@@ -263,7 +268,7 @@         runPgRowReader conn rowIdx res fields fromBackendRow >>= \case           Left err -> pure (PgStreamDone (Left err))           Right r -> pure (PgStreamContinue (next (Just r)))-      stepProcess (PgRunReturning _ _ _) _ = pure (PgStreamDone (Left (BeamRowReadError Nothing (ColumnErrorInternal "Nested queries not allowed"))))+      stepProcess (PgRunReturning {}) _ = pure (PgStreamDone (Left (BeamRowReadError Nothing (ColumnErrorInternal "Nested queries not allowed"))))       stepProcess (PgLiftWithHandle _ _) _ = pure (PgStreamDone (Left (BeamRowReadError Nothing (ColumnErrorInternal "Nested queries not allowed"))))        runConsumer :: forall a. PgStream a -> PgI.Row -> IO (PgStream a)@@ -277,13 +282,18 @@     PgLiftIO :: IO a -> (a -> next) -> PgF next     PgRunReturning ::         FromBackendRow Postgres x =>-        PgCommandSyntax -> (Pg (Maybe x) -> Pg a) -> (a -> next) -> PgF next+        FetchMode -> PgCommandSyntax -> (Pg (Maybe x) -> Pg a) -> (a -> next) -> PgF next     PgFetchNext ::         FromBackendRow Postgres x =>         (Maybe x -> next) -> PgF next     PgLiftWithHandle :: (Pg.Connection -> IO a) -> (a -> next) -> PgF next deriving instance Functor PgF +-- | How to fetch results.+data FetchMode+    = CursorBatching -- ^ Fetch in batches of ~256 rows via cursor for SELECT.+    | AtOnce         -- ^ Fetch all rows at once.+ -- | 'MonadBeam' in which we can run Postgres commands. See the documentation -- for 'MonadBeam' on examples of how to use. --@@ -293,12 +303,15 @@ newtype Pg a = Pg { runPg :: F PgF a }     deriving (Monad, Applicative, Functor, MonadFree PgF) -instance MonadFail Pg where-    fail e = fail $ "Internal Error with: " <> show e+instance Fail.MonadFail Pg where+    fail e =  liftIO (Fail.fail $ "Internal Error with: " <> show e)  instance MonadIO Pg where     liftIO x = liftF (PgLiftIO x id) +liftIOWithHandle :: (Pg.Connection -> IO a) -> Pg a+liftIOWithHandle f = liftF (PgLiftWithHandle f id)+ runBeamPostgresDebug :: (String -> IO ()) -> Pg.Connection -> Pg a -> IO a runBeamPostgresDebug dbg conn action =     withPgDebug dbg conn action >>= either throwIO pure@@ -308,7 +321,31 @@  instance MonadBeam Postgres Pg where     runReturningMany cmd consume =-        liftF (PgRunReturning cmd consume id)+        liftF (PgRunReturning CursorBatching cmd consume id)++    runReturningOne cmd =+        liftF (PgRunReturning AtOnce cmd consume id)+      where+        consume next = do+          a <- next+          case a of+            Nothing -> pure Nothing+            Just x -> do+              a' <- next+              case a' of+                Nothing -> pure (Just x)+                Just _ -> pure Nothing++    runReturningList cmd =+        liftF (PgRunReturning AtOnce cmd consume id)+      where+        consume next =+          let collectM acc = do+                a <- next+                case a of+                  Nothing -> pure (acc [])+                  Just x -> collectM (acc . (x:))+          in collectM id  instance MonadBeamInsertReturning Postgres Pg where     runInsertReturningList i = do

@@ -4,7 +4,8 @@ import           Database.Beam.Query import           Database.Beam.Postgres.Types (Postgres(..)) import           Database.Beam.Postgres.Connection-  ( Pg, PgF(..)+  ( Pg+  , liftIOWithHandle   , pgRenderSyntax ) import           Database.Beam.Postgres.Full   ( PgInsertReturning(..)@@ -17,10 +18,7 @@   , PgUpdateSyntax(..)   , PgDeleteSyntax(..) ) -import           Control.Monad.Free ( liftF )- import qualified Data.ByteString.Char8 as BC-import           Data.Maybe (maybe)  import qualified Database.PostgreSQL.Simple as Pg @@ -69,5 +67,5 @@  pgTraceStmt :: PgDebugStmt statement => statement -> Pg () pgTraceStmt stmt =-  liftF (PgLiftWithHandle (flip pgTraceStmtIO stmt) id)+  liftIOWithHandle (flip pgTraceStmtIO stmt) 

@@ -39,7 +39,7 @@ -- database, -- -- @--- import Database.Beam.Migrate.PgCrypto+-- import Database.Beam.Postgres.PgCrypto -- -- data MyDatabase entity --     = MyDatabase

@@ -0,0 +1,17 @@+module Database.Beam.Postgres.Extensions.Internal where++import Data.Text (Text)++import Database.Beam+import Database.Beam.Backend.SQL+import Database.Beam.Postgres++type PgExpr ctxt s = QGenExpr ctxt Postgres s++type family LiftPg ctxt s fn where+  LiftPg ctxt s (Maybe a -> b) = Maybe (PgExpr ctxt s a) -> LiftPg ctxt s b+  LiftPg ctxt s (a -> b) = PgExpr ctxt s a -> LiftPg ctxt s b+  LiftPg ctxt s a = PgExpr ctxt s a++funcE :: IsSql99ExpressionSyntax expr => Text -> [expr] -> expr+funcE nm args = functionCallE (fieldE (unqualifiedField nm)) args

@@ -0,0 +1,63 @@+-- | The @uuid-ossp@ extension provides functions for constructing UUIDs.+--+-- For an example of usage, see the documentation for 'PgExtensionEntity'.+module Database.Beam.Postgres.Extensions.UuidOssp+  ( UuidOssp(..)+  ) where++import           Data.Proxy (Proxy(..))+import           Data.Text (Text)+import           Data.UUID.Types (UUID)++import           Database.Beam+import           Database.Beam.Postgres.Extensions+import           Database.Beam.Postgres.Extensions.Internal++-- | Data type representing definitions contained in the @uuid-ossp@ extension+data UuidOssp = UuidOssp+  { pgUuidNil ::+      forall ctxt s. LiftPg ctxt s UUID+  , pgUuidNsDns ::+      forall ctxt s. LiftPg ctxt s UUID+  , pgUuidNsUrl ::+      forall ctxt s. LiftPg ctxt s UUID+  , pgUuidNsOid ::+      forall ctxt s. LiftPg ctxt s UUID+  , pgUuidNsX500 ::+      forall ctxt s. LiftPg ctxt s UUID+  , pgUuidGenerateV1 ::+      forall ctxt s. LiftPg ctxt s UUID+  , pgUuidGenerateV1Mc ::+      forall ctxt s. LiftPg ctxt s UUID+  , pgUuidGenerateV3 ::+      forall ctxt s. LiftPg ctxt s (UUID -> Text -> UUID)+  , pgUuidGenerateV4 ::+      forall ctxt s. LiftPg ctxt s UUID+  , pgUuidGenerateV5 ::+      forall ctxt s. LiftPg ctxt s (UUID -> Text -> UUID)+  }++instance IsPgExtension UuidOssp where+  pgExtensionName Proxy = "uuid-ossp"+  pgExtensionBuild = UuidOssp+    { pgUuidNil =+        QExpr $ funcE "uuid_nil" <$> sequenceA []+    , pgUuidNsDns =+        QExpr $ funcE "uuid_ns_dns" <$> sequenceA []+    , pgUuidNsUrl =+        QExpr $ funcE "uuid_ns_url" <$> sequenceA []+    , pgUuidNsOid =+        QExpr $ funcE "uuid_ns_oid" <$> sequenceA []+    , pgUuidNsX500 =+        QExpr $ funcE "uuid_ns_x500" <$> sequenceA []+    , pgUuidGenerateV1 =+        QExpr $ funcE "uuid_generate_v1" <$> sequenceA []+    , pgUuidGenerateV1Mc =+        QExpr $ funcE "uuid_generate_v1mc" <$> sequenceA []+    , pgUuidGenerateV3 = \(QExpr ns) (QExpr t) ->+        QExpr $ funcE "uuid_generate_v3" <$> sequenceA [ns, t]+    , pgUuidGenerateV4 =+        QExpr $ funcE "uuid_generate_v4" <$> sequenceA []+    , pgUuidGenerateV5 = \(QExpr ns) (QExpr t) ->+        QExpr $ funcE "uuid_generate_v5" <$> sequenceA [ns, t]+    }

@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TupleSections #-}@@ -30,14 +31,13 @@    -- ** Specifying conflict actions -  , PgInsertOnConflict(..), PgInsertOnConflictTarget(..)-  , PgConflictAction(..)+  , PgInsertOnConflict(..) -  , onConflictDefault, onConflict, anyConflict, conflictingFields-  , conflictingFieldsWhere, conflictingConstraint-  , onConflictDoNothing, onConflictUpdateSet-  , onConflictUpdateSetWhere, onConflictUpdateInstead-  , onConflictSetAll+  , onConflictDefault, onConflict+  , conflictingConstraint+  , BeamHasInsertOnConflict(..)+  , onConflictUpdateAll+  , onConflictUpdateInstead    -- * @UPDATE RETURNING@   , PgUpdateReturning(..)@@ -56,15 +56,14 @@ import           Database.Beam hiding (insert, insertValues) import           Database.Beam.Query.Internal import           Database.Beam.Backend.SQL+import           Database.Beam.Backend.SQL.BeamExtensions import           Database.Beam.Schema.Tables  import           Database.Beam.Postgres.Types import           Database.Beam.Postgres.Syntax  import           Control.Monad.Free.Church-import           Control.Monad.Writer (execWriter, tell) -import           Data.Functor.Const import           Data.Proxy (Proxy(..)) import qualified Data.Text as T #if !MIN_VERSION_base(4, 11, 0)@@ -94,7 +93,7 @@ lockAll_ = PgWithLocking mempty  -- | Return and lock the given tables. Typically used as an infix operator. See the--- <http://tathougies.github.io/beam/user-guide/backends/beam-postgres/ the user guide> for usage+-- <https://haskell-beam.github.io/beam/user-guide/backends/beam-postgres/ the user guide> for usage -- examples withLocks_ :: a -> PgLockedTables s -> PgWithLocking s a withLocks_ = flip PgWithLocking@@ -113,7 +112,7 @@  -- | Lock some tables during the execution of a query. This is rather complicated, and there are -- several usage examples in--- <http://tathougies.github.io/beam/user-guide/backends/beam-postgres/ the user guide>+-- <https://haskell-beam.github.io/beam/user-guide/backends/beam-postgres/ the user guide> -- -- The Postgres locking clause is rather complex, and beam currently does not check several -- pre-conditions. It is assumed you kinda know what you're doing.@@ -231,15 +230,7 @@ -- | What to do when an @INSERT@ statement inserts a row into the table @tbl@ -- that violates a constraint. newtype PgInsertOnConflict (tbl :: (* -> *) -> *) =-    PgInsertOnConflict (tbl (QField PostgresInaccessible) -> PgInsertOnConflictSyntax)---- | Specifies the kind of constraint that must be violated for the action to occur-newtype PgInsertOnConflictTarget (tbl :: (* -> *) -> *) =-    PgInsertOnConflictTarget (tbl (QExpr Postgres PostgresInaccessible) -> PgInsertOnConflictTargetSyntax)---- | A description of what to do when a constraint or index is violated.-newtype PgConflictAction (tbl :: (* -> *) -> *) =-    PgConflictAction (tbl (QField PostgresInaccessible) -> PgConflictActionSyntax)+    PgInsertOnConflict (tbl (QField QInternal) -> PgInsertOnConflictSyntax)  -- | Postgres @LATERAL JOIN@ support --@@ -296,8 +287,8 @@ -- See the -- <https://www.postgresql.org/docs/current/static/sql-insert.html Postgres documentation>. onConflict :: Beamable tbl-           => PgInsertOnConflictTarget tbl-           -> PgConflictAction tbl+           => SqlConflictTarget Postgres tbl+           -> SqlConflictAction Postgres tbl            -> PgInsertOnConflict tbl onConflict (PgInsertOnConflictTarget tgt) (PgConflictAction update_) =   PgInsertOnConflict $ \tbl ->@@ -308,123 +299,13 @@      emit "ON CONFLICT " <> fromPgInsertOnConflictTarget (tgt exprTbl)                          <> fromPgConflictAction (update_ tbl) --- | Perform the conflict action when any constraint or index conflict occurs.--- Syntactically, this is the @ON CONFLICT@ clause, without any /conflict target/.-anyConflict :: PgInsertOnConflictTarget tbl-anyConflict = PgInsertOnConflictTarget (\_ -> PgInsertOnConflictTargetSyntax mempty)---- | Perform the conflict action only when these fields conflict. The first--- argument gets the current row as a table of expressions. Return the conflict--- key. For more information, see the @beam-postgres@ manual.-conflictingFields :: Projectible Postgres proj-                  => (tbl (QExpr Postgres PostgresInaccessible) -> proj)-                  -> PgInsertOnConflictTarget tbl-conflictingFields makeProjection =-  PgInsertOnConflictTarget $ \tbl ->-  PgInsertOnConflictTargetSyntax $-  pgParens (pgSepBy (emit ", ") $-            map fromPgExpression $-            project (Proxy @Postgres) (makeProjection tbl) "t") <>-  emit " "---- | Like 'conflictingFields', but only perform the action if the condition--- given in the second argument is met. See the postgres--- <https://www.postgresql.org/docs/current/static/sql-insert.html manual> for--- more information.-conflictingFieldsWhere :: Projectible Postgres proj-                       => (tbl (QExpr Postgres PostgresInaccessible) -> proj)-                       -> (tbl (QExpr Postgres PostgresInaccessible) ->-                           QExpr Postgres PostgresInaccessible Bool)-                       -> PgInsertOnConflictTarget tbl-conflictingFieldsWhere makeProjection makeWhere =-  PgInsertOnConflictTarget $ \tbl ->-  PgInsertOnConflictTargetSyntax $-  pgParens (pgSepBy (emit ", ") $-            map fromPgExpression (project (Proxy @Postgres)-                                          (makeProjection tbl) "t")) <>-  emit " WHERE " <>-  pgParens (let QExpr mkE = makeWhere tbl-                PgExpressionSyntax e = mkE "t"-            in e) <>-  emit " "- -- | Perform the action only if the given named constraint is violated-conflictingConstraint :: T.Text -> PgInsertOnConflictTarget tbl+conflictingConstraint :: T.Text -> SqlConflictTarget Postgres tbl conflictingConstraint nm =   PgInsertOnConflictTarget $ \_ ->   PgInsertOnConflictTargetSyntax $   emit "ON CONSTRAINT " <> pgQuotedIdentifier nm <> emit " " --- | The Postgres @DO NOTHING@ action-onConflictDoNothing :: PgConflictAction tbl-onConflictDoNothing = PgConflictAction $ \_ -> PgConflictActionSyntax (emit "DO NOTHING")---- | The Postgres @DO UPDATE SET@ action, without the @WHERE@ clause. The--- argument takes an updatable row (like the one used in 'update') and the--- conflicting row. Use 'current_' on the first argument to get the current--- value of the row in the database.-onConflictUpdateSet :: Beamable tbl-                    => (tbl (QField PostgresInaccessible) ->-                        tbl (QExpr Postgres PostgresInaccessible)  ->-                        QAssignment Postgres PostgresInaccessible)-                    -> PgConflictAction tbl-onConflictUpdateSet mkAssignments =-  PgConflictAction $ \tbl ->-  let QAssignment assignments = mkAssignments tbl tblExcluded-      tblExcluded = changeBeamRep (\(Columnar' (QField _ _ nm)) -> Columnar' (QExpr (\_ -> fieldE (qualifiedField "excluded" nm)))) tbl--      assignmentSyntaxes =-        [ fromPgFieldName fieldNm <> emit "=" <> pgParens (fromPgExpression expr)-        | (fieldNm, expr) <- assignments ]-  in PgConflictActionSyntax $-     emit "DO UPDATE SET " <> pgSepBy (emit ", ") assignmentSyntaxes---- | The Postgres @DO UPDATE SET@ action, with the @WHERE@ clause. This is like--- 'onConflictUpdateSet', but only rows satisfying the given condition are--- updated. Sometimes this results in more efficient locking. See the Postgres--- <https://www.postgresql.org/docs/current/static/sql-insert.html manual> for--- more information.-onConflictUpdateSetWhere :: Beamable tbl-                         => (tbl (QField PostgresInaccessible) ->-                             tbl (QExpr Postgres PostgresInaccessible)  ->-                             QAssignment Postgres PostgresInaccessible)-                         -> (tbl (QExpr Postgres PostgresInaccessible) -> QExpr Postgres PostgresInaccessible Bool)-                         -> PgConflictAction tbl-onConflictUpdateSetWhere mkAssignments where_ =-  PgConflictAction $ \tbl ->-  let QAssignment assignments = mkAssignments tbl tblExcluded-      QExpr where_' = where_ (changeBeamRep (\(Columnar' f) -> Columnar' (current_ f)) tbl)-      tblExcluded = changeBeamRep (\(Columnar' (QField _ _ nm)) -> Columnar' (QExpr (\_ -> fieldE (qualifiedField "excluded" nm)))) tbl--      assignmentSyntaxes =-        [ fromPgFieldName fieldNm <> emit "=" <> pgParens (fromPgExpression expr)-        | (fieldNm, expr) <- assignments ]-  in PgConflictActionSyntax $-     emit "DO UPDATE SET " <> pgSepBy (emit ", ") assignmentSyntaxes <> emit " WHERE " <> fromPgExpression (where_' "t")---- | Sometimes you want to update certain columns in the row. Given a--- projection from a row to the fields you want, Beam can auto-generate--- an assignment that assigns the corresponding fields of the conflicting row.-onConflictUpdateInstead :: (Beamable tbl, ProjectibleWithPredicate AnyType () T.Text proj)-                        => (tbl (Const T.Text) -> proj)-                        -> PgConflictAction tbl-onConflictUpdateInstead mkProj =-  onConflictUpdateSet $ \tbl _ ->-  let tblFields = changeBeamRep (\(Columnar' (QField _ _ nm) :: Columnar' (QField PostgresInaccessible) a) -> Columnar' (Const nm) :: Columnar' (Const T.Text) a) tbl-      proj = execWriter (project' (Proxy @AnyType) (Proxy @((), T.Text))-                                  (\_ _ e -> tell [e] >> pure e)-                                  (mkProj tblFields))--  in QAssignment (map (\fieldNm -> (unqualifiedField fieldNm, fieldE (qualifiedField "excluded" fieldNm))) proj)---- | Sometimes you want to update every value in the row. Beam can auto-generate--- an assignment that assigns the conflicting row to every field in the database--- row. This may not always be what you want.-onConflictSetAll :: ( Beamable tbl-                    , ProjectibleWithPredicate AnyType () T.Text (tbl (Const T.Text)) )-                 => PgConflictAction tbl-onConflictSetAll = onConflictUpdateInstead id- -- * @UPDATE@  -- | The most general kind of @UPDATE@ that postgres can perform@@ -555,3 +436,77 @@      where       tblQ = changeBeamRep (\(Columnar' f) -> Columnar' (QExpr . pure . fieldE . unqualifiedField . _fieldName $ f)) tblSettings++instance BeamHasInsertOnConflict Postgres where+  newtype SqlConflictTarget Postgres table =+    PgInsertOnConflictTarget (table (QExpr Postgres QInternal) -> PgInsertOnConflictTargetSyntax)+  newtype SqlConflictAction Postgres table =+    PgConflictAction (table (QField QInternal) -> PgConflictActionSyntax)++  insertOnConflict tbl vs target action = insert tbl vs $ onConflict target action++  -- | Perform the conflict action when any constraint or index conflict occurs.+  -- Syntactically, this is the @ON CONFLICT@ clause, without any /conflict target/.+  anyConflict = PgInsertOnConflictTarget (\_ -> PgInsertOnConflictTargetSyntax mempty)++  -- | The Postgres @DO NOTHING@ action+  onConflictDoNothing = PgConflictAction $ \_ -> PgConflictActionSyntax (emit "DO NOTHING")++  -- | The Postgres @DO UPDATE SET@ action, without the @WHERE@ clause. The+  -- argument takes an updatable row (like the one used in 'update') and the+  -- conflicting row. Use 'current_' on the first argument to get the current+  -- value of the row in the database.+  onConflictUpdateSet mkAssignments =+    PgConflictAction $ \tbl ->+    let QAssignment assignments = mkAssignments tbl tblExcluded+        tblExcluded = changeBeamRep (\(Columnar' (QField _ _ nm)) -> Columnar' (QExpr (\_ -> fieldE (qualifiedField "excluded" nm)))) tbl++        assignmentSyntaxes =+          [ fromPgFieldName fieldNm <> emit "=" <> pgParens (fromPgExpression expr)+          | (fieldNm, expr) <- assignments ]+    in PgConflictActionSyntax $+       emit "DO UPDATE SET " <> pgSepBy (emit ", ") assignmentSyntaxes++  -- | The Postgres @DO UPDATE SET@ action, with the @WHERE@ clause. This is like+  -- 'onConflictUpdateSet', but only rows satisfying the given condition are+  -- updated. Sometimes this results in more efficient locking. See the Postgres+  -- <https://www.postgresql.org/docs/current/static/sql-insert.html manual> for+  -- more information.+  onConflictUpdateSetWhere mkAssignments where_ =+    PgConflictAction $ \tbl ->+    let QAssignment assignments = mkAssignments tbl tblExcluded+        QExpr where_' = where_ tbl tblExcluded+        tblExcluded = changeBeamRep (\(Columnar' (QField _ _ nm)) -> Columnar' (QExpr (\_ -> fieldE (qualifiedField "excluded" nm)))) tbl++        assignmentSyntaxes =+          [ fromPgFieldName fieldNm <> emit "=" <> pgParens (fromPgExpression expr)+          | (fieldNm, expr) <- assignments ]+    in PgConflictActionSyntax $+       emit "DO UPDATE SET " <> pgSepBy (emit ", ") assignmentSyntaxes <> emit " WHERE " <> fromPgExpression (where_' "t")++  -- | Perform the conflict action only when these fields conflict. The first+  -- argument gets the current row as a table of expressions. Return the conflict+  -- key. For more information, see the @beam-postgres@ manual.+  conflictingFields makeProjection =+    PgInsertOnConflictTarget $ \tbl ->+    PgInsertOnConflictTargetSyntax $+    pgParens (pgSepBy (emit ", ") $+              map fromPgExpression $+              project (Proxy @Postgres) (makeProjection tbl) "t") <>+    emit " "++  -- | Like 'conflictingFields', but only perform the action if the condition+  -- given in the second argument is met. See the postgres+  -- <https://www.postgresql.org/docs/current/static/sql-insert.html manual> for+  -- more information.+  conflictingFieldsWhere makeProjection makeWhere =+    PgInsertOnConflictTarget $ \tbl ->+    PgInsertOnConflictTargetSyntax $+    pgParens (pgSepBy (emit ", ") $+              map fromPgExpression (project (Proxy @Postgres)+                                            (makeProjection tbl) "t")) <>+    emit " WHERE " <>+    pgParens (let QExpr mkE = makeWhere tbl+                  PgExpressionSyntax e = mkE "t"+              in e) <>+    emit " "

@@ -14,6 +14,7 @@   , postgresDataTypeDeserializers   , pgPredConverter   , getDbConstraints+  , getDbConstraintsForSchemas   , pgTypeToHs   , migrateScript   , writeMigrationScript@@ -54,7 +55,6 @@ import           Control.Arrow import           Control.Exception (bracket) import           Control.Monad-import           Control.Monad.Free.Church (liftF)  import           Data.Aeson hiding (json) import           Data.Bits@@ -89,7 +89,7 @@                                  , "  postgresql://[user[:password]@][netloc][:port][/dbname][?param1=value1&...]"                                  , ""                                  , "See <https://www.postgresql.org/docs/9.5/static/libpq-connect.html#LIBPQ-CONNSTRING> for more information" ])-                        (liftF (PgLiftWithHandle getDbConstraints id))+                        (liftIOWithHandle getDbConstraints)                         (Db.sql92Deserializers <> Db.sql99DataTypeDeserializers <>                          Db.sql2008BigIntDataTypeDeserializers <>                          postgresDataTypeDeserializers <>@@ -324,8 +324,13 @@ -- * Create constraints from a connection  getDbConstraints :: Pg.Connection -> IO [ Db.SomeDatabasePredicate ]-getDbConstraints conn =-  do tbls <- Pg.query_ conn "SELECT cl.oid, relname FROM pg_catalog.pg_class \"cl\" join pg_catalog.pg_namespace \"ns\" on (ns.oid = relnamespace) where nspname = any (current_schemas(false)) and relkind='r'"+getDbConstraints = getDbConstraintsForSchemas Nothing++getDbConstraintsForSchemas :: Maybe [String] -> Pg.Connection -> IO [ Db.SomeDatabasePredicate ]+getDbConstraintsForSchemas subschemas conn =+  do tbls <- case subschemas of+        Nothing -> Pg.query_ conn "SELECT cl.oid, relname FROM pg_catalog.pg_class \"cl\" join pg_catalog.pg_namespace \"ns\" on (ns.oid = relnamespace) where nspname = any (current_schemas(false)) and relkind='r'"+        Just ss -> Pg.query  conn "SELECT cl.oid, relname FROM pg_catalog.pg_class \"cl\" join pg_catalog.pg_namespace \"ns\" on (ns.oid = relnamespace) where nspname IN ? and relkind='r'" (Pg.Only (Pg.In ss))      let tblsExist = map (\(_, tbl) -> Db.SomeDatabasePredicate (Db.TableExistsPredicate (Db.QualifiedName Nothing tbl))) tbls       enumerationData <-@@ -362,12 +367,17 @@                                            , "CROSS JOIN unnest(i.indkey) WITH ORDINALITY k(attid, n)"                                            , "JOIN pg_attribute a ON a.attnum=k.attid AND a.attrelid=i.indrelid"                                            , "JOIN pg_class c ON c.oid=i.indrelid"-                                           , "WHERE c.relkind='r' AND i.indisprimary GROUP BY relname, i.indrelid" ]))+                                           , "JOIN pg_namespace ns ON ns.oid=c.relnamespace"+                                           , "WHERE ns.nspname = any (current_schemas(false)) AND c.relkind='r' AND i.indisprimary GROUP BY relname, i.indrelid" ]))       let enumerations =            map (\(enumNm, _, options) -> Db.SomeDatabasePredicate (PgHasEnum enumNm (V.toList options))) enumerationData -     pure (tblsExist ++ columnChecks ++ primaryKeys ++ enumerations)+     extensions <-+       map (\(Pg.Only extname) -> Db.SomeDatabasePredicate (PgHasExtension extname)) <$>+       Pg.query_ conn "SELECT extname from pg_extension"++     pure (tblsExist ++ columnChecks ++ primaryKeys ++ enumerations ++ extensions)  -- * Postgres-specific data types 

@@ -1,3 +1,4 @@+ -- | The @pgcrypto@ extension provides several cryptographic functions to -- Postgres. This module provides a @beam-postgres@ extension to access this -- functionality. For an example of usage, see the documentation for@@ -8,21 +9,15 @@ import Database.Beam import Database.Beam.Backend.SQL -import Database.Beam.Postgres.Types import Database.Beam.Postgres.Extensions+import Database.Beam.Postgres.Extensions.Internal +import Data.Int import Data.Text (Text) import Data.ByteString (ByteString) import Data.Vector (Vector) import Data.UUID.Types (UUID) -type PgExpr ctxt s = QGenExpr ctxt Postgres s--type family LiftPg ctxt s fn where-  LiftPg ctxt s (Maybe a -> b) = Maybe (PgExpr ctxt s a) -> LiftPg ctxt s b-  LiftPg ctxt s (a -> b) = PgExpr ctxt s a -> LiftPg ctxt s b-  LiftPg ctxt s a = PgExpr ctxt s a- -- | Data type representing definitions contained in the @pgcrypto@ extension -- -- Each field maps closely to the underlying @pgcrypto@ function, which are@@ -41,7 +36,7 @@   , pgCryptoCrypt ::       forall ctxt s. LiftPg ctxt s (Text -> Text -> Text)   , pgCryptoGenSalt ::-      forall ctxt s. LiftPg ctxt s (Text -> Maybe Int -> Text)+      forall ctxt s. LiftPg ctxt s (Text -> Maybe Int32 -> Text)    -- Pgp functions   , pgCryptoPgpSymEncrypt ::@@ -83,9 +78,6 @@   , pgCryptoGenRandomUUID ::       forall ctxt s. PgExpr ctxt s UUID   }--funcE :: IsSql99ExpressionSyntax expr => Text -> [expr] -> expr-funcE nm args = functionCallE (fieldE (unqualifiedField nm)) args  instance IsPgExtension PgCrypto where   pgExtensionName _ = "pgcrypto"

@@ -38,6 +38,7 @@   , withoutKeys    , pgJsonArrayLength+  , pgArrayToJson   , pgJsonbUpdate, pgJsonbSet   , pgJsonbPretty @@ -56,6 +57,12 @@   , PgBox(..), PgPath(..), PgPolygon(..)   , PgCircle(..) +    -- ** Regular expressions+  , PgRegex(..), pgRegex_+  , (~.), (~*.), (!~.), (!~*.)+  , pgRegexpReplace_, pgRegexpMatch_+  , pgRegexpSplitToTable, pgRegexpSplitToArray+     -- ** Set-valued functions     -- $set-valued-funs   , PgSetOf, pgUnnest@@ -86,7 +93,7 @@      -- *** Building ranges from expressions   , range_-  +     -- *** Building @PgRangeBound@s   , inclusive, exclusive, unbounded @@ -98,7 +105,7 @@   , rLower_, rUpper_, isEmpty_   , lowerInc_, upperInc_, lowerInf_, upperInf_   , rangeMerge_-  +     -- ** Postgres functions and aggregates   , pgBoolOr, pgBoolAnd, pgStringAgg, pgStringAggOver @@ -127,7 +134,9 @@ import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as BL import           Data.Foldable+import           Data.Functor import           Data.Hashable+import           Data.Int import qualified Data.List.NonEmpty as NE import           Data.Proxy import           Data.Scientific (Scientific, formatScientific, FPFormat(Fixed))@@ -703,9 +712,10 @@   fromField field d =     if Pg.typeOid field /= Pg.typoid Pg.json     then Pg.returnError Pg.Incompatible field ""-    else case decodeStrict =<< d of-           Just d' -> pure (PgJSON d')+    else case eitherDecodeStrict <$> d of            Nothing -> Pg.returnError Pg.UnexpectedNull field ""+           Just (Left e) -> Pg.returnError Pg.ConversionFailed field e+           Just (Right d') -> pure (PgJSON d')  instance (Typeable a, FromJSON a) => FromBackendRow Postgres (PgJSON a) instance ToJSON a => HasSqlValueSyntax PgValueSyntax (PgJSON a) where@@ -715,7 +725,7 @@  -- | The Postgres @JSONB@ type, which stores JSON-encoded data in a -- postgres-specific binary format. Like 'PgJSON', the type parameter indicates--- the Hgaskell type which the JSON encodes.+-- the Haskell type which the JSON encodes. -- -- Fields with this type are automatically given the Postgres @JSONB@ type newtype PgJSONB a = PgJSONB a@@ -728,9 +738,10 @@   fromField field d =     if Pg.typeOid field /= Pg.typoid Pg.jsonb     then Pg.returnError Pg.Incompatible field ""-    else case decodeStrict =<< d of-           Just d' -> pure (PgJSONB d')+    else case eitherDecodeStrict <$> d of            Nothing -> Pg.returnError Pg.UnexpectedNull field ""+           Just (Left e) -> Pg.returnError Pg.ConversionFailed field e+           Just (Right d') -> pure (PgJSONB d')  instance (Typeable a, FromJSON a) => FromBackendRow Postgres (PgJSONB a) instance ToJSON a => HasSqlValueSyntax PgValueSyntax (PgJSONB a) where@@ -867,10 +878,10 @@ -- | Postgres @&#x40;>@ and @<&#x40;@ operators for JSON. Return true if the -- json object pointed to by the arrow is completely contained in the other. See -- the Postgres documentation for more in formation on what this means.-(@>), (<@) :: IsPgJSON json-           => QGenExpr ctxt Postgres s (json a)-           -> QGenExpr ctxt Postgres s (json b)-           -> QGenExpr ctxt Postgres s Bool+(@>), (<@)+  :: QGenExpr ctxt Postgres s (PgJSONB a)+  -> QGenExpr ctxt Postgres s (PgJSONB b)+  -> QGenExpr ctxt Postgres s Bool QExpr a @> QExpr b =   QExpr (pgBinOp "@>" <$> a <*> b) QExpr a <@ QExpr b =@@ -880,7 +891,7 @@ -- See '(->$)' for the corresponding operator for object access. (->#) :: IsPgJSON json       => QGenExpr ctxt Postgres s (json a)-      -> QGenExpr ctxt Postgres s Int+      -> QGenExpr ctxt Postgres s Int32       -> QGenExpr ctxt Postgres s (json b) QExpr a -># QExpr b =   QExpr (pgBinOp "->" <$> a <*> b)@@ -899,7 +910,7 @@ -- corresponding operator on objects. (->>#) :: IsPgJSON json        => QGenExpr ctxt Postgres s (json a)-       -> QGenExpr ctxt Postgres s Int+       -> QGenExpr ctxt Postgres s Int32        -> QGenExpr ctxt Postgres s T.Text QExpr a ->># QExpr b =   QExpr (pgBinOp "->>" <$> a <*> b)@@ -936,19 +947,19 @@  -- | Postgres @?@ operator. Checks if the given string exists as top-level key -- of the json object.-(?) :: IsPgJSON json-    => QGenExpr ctxt Postgres s (json a)-    -> QGenExpr ctxt Postgres s T.Text-    -> QGenExpr ctxt Postgres s Bool+(?)+  :: QGenExpr ctxt Postgres s (PgJSONB a)+  -> QGenExpr ctxt Postgres s T.Text+  -> QGenExpr ctxt Postgres s Bool QExpr a ? QExpr b =   QExpr (pgBinOp "?" <$> a <*> b)  -- | Postgres @?|@ and @?&@ operators. Check if any or all of the given strings -- exist as top-level keys of the json object respectively.-(?|), (?&) :: IsPgJSON json-           => QGenExpr ctxt Postgres s (json a)-           -> QGenExpr ctxt Postgres s (V.Vector T.Text)-           -> QGenExpr ctxt Postgres s Bool+(?|), (?&)+  :: QGenExpr ctxt Postgres s (PgJSONB a)+  -> QGenExpr ctxt Postgres s (V.Vector T.Text)+  -> QGenExpr ctxt Postgres s Bool QExpr a ?| QExpr b =   QExpr (pgBinOp "?|" <$> a <*> b) QExpr a ?& QExpr b =@@ -957,39 +968,48 @@ -- | Postgres @-@ operator on json objects. Returns the supplied json object -- with the supplied key deleted. See 'withoutIdx' for the corresponding -- operator on arrays.-withoutKey :: IsPgJSON json-           => QGenExpr ctxt Postgres s (json a)-           -> QGenExpr ctxt Postgres s T.Text-           -> QGenExpr ctxt Postgres s (json b)+withoutKey+  :: QGenExpr ctxt Postgres s (PgJSONB a)+  -> QGenExpr ctxt Postgres s T.Text+  -> QGenExpr ctxt Postgres s (PgJSONB b) QExpr a `withoutKey` QExpr b =   QExpr (pgBinOp "-" <$> a <*> b)  -- | Postgres @-@ operator on json arrays. See 'withoutKey' for the -- corresponding operator on objects.-withoutIdx :: IsPgJSON json-           => QGenExpr ctxt Postgres s (json a)-           -> QGenExpr ctxt Postgres s Int-           -> QGenExpr ctxt Postgres s (json b)+withoutIdx+  :: QGenExpr ctxt Postgres s (PgJSONB a)+  -> QGenExpr ctxt Postgres s Int32+  -> QGenExpr ctxt Postgres s (PgJSONB b) QExpr a `withoutIdx` QExpr b =   QExpr (pgBinOp "-" <$> a <*> b)  -- | Postgres @#-@ operator. Removes all the keys specificied from the JSON -- object and returns the result.-withoutKeys :: IsPgJSON json-            => QGenExpr ctxt Postgres s (json a)-            -> QGenExpr ctxt Postgres s (V.Vector T.Text)-            -> QGenExpr ctxt Postgres s (json b)+withoutKeys+  :: QGenExpr ctxt Postgres s (PgJSONB a)+  -> QGenExpr ctxt Postgres s (V.Vector T.Text)+  -> QGenExpr ctxt Postgres s (PgJSONB b) QExpr a `withoutKeys` QExpr b =   QExpr (pgBinOp "#-" <$> a <*> b)  -- | Postgres @json_array_length@ function. The supplied json object should be -- an array, but this isn't checked at compile-time. pgJsonArrayLength :: IsPgJSON json => QGenExpr ctxt Postgres s (json a)-                  -> QGenExpr ctxt Postgres s Int+                  -> QGenExpr ctxt Postgres s Int32 pgJsonArrayLength (QExpr a) =   QExpr $ \tbl ->   PgExpressionSyntax (emit "json_array_length(" <> fromPgExpression (a tbl) <> emit ")") +-- | Postgres @array_to_json@ function.+pgArrayToJson+  :: QGenExpr ctxt Postgres s (V.Vector e)+  -> QGenExpr ctxt Postgres s (PgJSON a)+pgArrayToJson (QExpr a) = QExpr $ a <&> PgExpressionSyntax .+  mappend (emit "array_to_json") .+  pgParens .+  fromPgExpression+ -- | The postgres @jsonb_set@ function. 'pgJsonUpdate' expects the value -- specified by the path in the second argument to exist. If it does not, the -- first argument is not modified. 'pgJsonbSet' will create any intermediate@@ -1260,7 +1280,101 @@                             <*> pgPointParser instance FromBackendRow Postgres PgBox +-- ** Regular expressions +-- | The type of Postgres regular expressions. Only a+-- 'HasSqlValueSyntax' instance is supplied, because you won't need to+-- be reading these back from the database.+--+-- If you're generating regexes dynamically, then use 'pgRegex_' to+-- convert a string expression into a regex one.+newtype PgRegex = PgRegex T.Text+  deriving (Show, Eq, Ord, IsString)++instance HasSqlValueSyntax PgValueSyntax PgRegex where+  sqlValueSyntax (PgRegex r) = sqlValueSyntax r++-- | Convert a string valued expression (which could be generated+-- dynamically) into a 'PgRegex'-typed one.+pgRegex_ :: BeamSqlBackendIsString Postgres text => QGenExpr ctxt Postgres s text -> QGenExpr ctxt Postgres s PgRegex+pgRegex_ (QExpr e) = QExpr e++-- | Match regular expression, case-sensitive+(~.) :: BeamSqlBackendIsString Postgres text+     => QGenExpr ctxt Postgres s text -> QGenExpr ctxt Postgres s PgRegex+     -> QGenExpr ctxt Postgres s Bool+QExpr t ~. QExpr re = QExpr (pgBinOp "~" <$> t <*> re)++-- | Match regular expression, case-insensitive+(~*.) :: BeamSqlBackendIsString Postgres text+      => QGenExpr ctxt Postgres s text -> QGenExpr ctxt Postgres s PgRegex+      -> QGenExpr ctxt Postgres s Bool+QExpr t ~*. QExpr re = QExpr (pgBinOp "~*" <$> t <*> re)++-- | Does not match regular expression, case-sensitive+(!~.) :: BeamSqlBackendIsString Postgres text+      => QGenExpr ctxt Postgres s text -> QGenExpr ctxt Postgres s PgRegex+      -> QGenExpr ctxt Postgres s Bool+QExpr t !~. QExpr re = QExpr (pgBinOp "!~" <$> t <*> re)++-- | Does not match regular expression, case-insensitive+(!~*.) :: BeamSqlBackendIsString Postgres text+       => QGenExpr ctxt Postgres s text -> QGenExpr ctxt Postgres s PgRegex+       -> QGenExpr ctxt Postgres s Bool+QExpr t !~*. QExpr re = QExpr (pgBinOp "!~*" <$> t <*> re)++-- | Postgres @regexp_replace@. Replaces all instances of the regex in+-- the first argument with the third argument. The fourth argument is+-- the postgres regex options to provide.+pgRegexpReplace_ :: BeamSqlBackendIsString Postgres text+                 => QGenExpr ctxt Postgres s text -> QGenExpr ctxt Postgres s PgRegex+                 -> QGenExpr ctxt Postgres s text -> QGenExpr ctxt Postgres s T.Text+                 -> QGenExpr ctxt Postgres s txt+pgRegexpReplace_ (QExpr haystack) (QExpr needle) (QExpr replacement) (QExpr opts) =+  QExpr (\t -> PgExpressionSyntax $+               emit "regexp_replace(" <> fromPgExpression (haystack t) <> emit ", "+                                      <> fromPgExpression (needle t) <> emit ", "+                                      <> fromPgExpression (replacement t) <> emit ", "+                                      <> fromPgExpression (opts t) <> emit ")")++-- | Postgres @regexp_match@. Matches the regular expression against+-- the string given and returns an array where each element+-- corresponds to a match in the string, or @NULL@ if nothing was+-- found+pgRegexpMatch_ :: BeamSqlBackendIsString Postgres text+               => QGenExpr ctxt Postgres s text -> QGenExpr ctxt Postgres s PgRegex+               -> QGenExpr ctxt Postgres s (Maybe (V.Vector text))+pgRegexpMatch_ (QExpr s) (QExpr re) =+  QExpr (\t -> PgExpressionSyntax $+               emit "regexp_match(" <> fromPgExpression (s t) <> emit ", "+                                    <> fromPgExpression (re t) <> emit ")")++-- | Postgres @regexp_split_to_array@. Splits the given string by the+-- given regex and returns the result as an array.+pgRegexpSplitToArray :: BeamSqlBackendIsString Postgres text+                     => QGenExpr ctxt Postgres s text -> QGenExpr ctxt Postgres s PgRegex+                     -> QGenExpr ctxt Postgres s (V.Vector text)+pgRegexpSplitToArray (QExpr s) (QExpr re) =+  QExpr (\t -> PgExpressionSyntax $+               emit "regexp_split_to_array(" <> fromPgExpression (s t) <> emit ", "+                                             <> fromPgExpression (re t) <> emit ")")++newtype PgReResultT f+  = PgReResultT { reResult :: C f T.Text }+  deriving Generic+instance Beamable PgReResultT++-- | Postgres @regexp_split_to_table@. Splits the given string by the+-- given regex and return a result set that can be joined against.+pgRegexpSplitToTable :: BeamSqlBackendIsString Postgres text+                     => QGenExpr ctxt Postgres s text -> QGenExpr ctxt Postgres s PgRegex++                     -> Q Postgres db s (QExpr Postgres s T.Text)+pgRegexpSplitToTable (QExpr s) (QExpr re) =+  fmap reResult $+  pgUnnest' (\t -> emit "regexp_split_to_table(" <> fromPgExpression (s t) <> emit ", "+                                                 <> fromPgExpression (re t) <> emit ")")+ -- ** Set-valued functions  data PgSetOf (tbl :: (* -> *) -> *)@@ -1288,6 +1402,7 @@                                       pure (Columnar' (TableField (pure fieldNm) fieldNm)))                                 tblSkeleton tblSkeleton) (0 :: Int) +-- | Join the results of the given set-valued function to the query pgUnnest :: forall tbl db s           . Beamable tbl          => QExpr Postgres s (PgSetOf tbl)@@ -1299,18 +1414,21 @@   deriving Generic instance Beamable (PgUnnestArrayTbl a) +-- | Introduce each element of the array as a row pgUnnestArray :: QExpr Postgres s (V.Vector a)               -> Q Postgres db s (QExpr Postgres s a) pgUnnestArray (QExpr q) =   fmap (\(PgUnnestArrayTbl x) -> x) $   pgUnnest' (\t -> emit "UNNEST" <> pgParens (fromPgExpression (q t))) -data PgUnnestArrayWithOrdinalityTbl a f = PgUnnestArrayWithOrdinalityTbl (C f Int) (C f a)+data PgUnnestArrayWithOrdinalityTbl a f = PgUnnestArrayWithOrdinalityTbl (C f Int64) (C f a)   deriving Generic instance Beamable (PgUnnestArrayWithOrdinalityTbl a) +-- | Introduce each element of the array as a row, along with the+-- element's index pgUnnestArrayWithOrdinality :: QExpr Postgres s (V.Vector a)-                            -> Q Postgres db s (QExpr Postgres s Int, QExpr Postgres s a)+                            -> Q Postgres db s (QExpr Postgres s Int64, QExpr Postgres s a) pgUnnestArrayWithOrdinality (QExpr q) =   fmap (\(PgUnnestArrayWithOrdinalityTbl i x) -> (i, x)) $   pgUnnest' (\t -> emit "UNNEST" <> pgParens (fromPgExpression (q t)) <> emit " WITH ORDINALITY")@@ -1406,7 +1524,7 @@ -- know the shape of the data stored, substitute 'Value' for this type -- parameter. ----- For more information on Psotgres json support see the postgres+-- For more information on Postgres JSON support see the postgres -- <https://www.postgresql.org/docs/current/static/functions-json.html manual>.  

@@ -11,6 +11,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE UndecidableInstances #-}  -- | Data types for Postgres syntax. Access is given mainly for extension -- modules. The types and definitions here are likely to change.@@ -86,9 +87,9 @@     , PostgresInaccessible ) where  import           Database.Beam hiding (insert)+import           Database.Beam.Backend.Internal.Compat import           Database.Beam.Backend.SQL import           Database.Beam.Migrate-import           Database.Beam.Migrate.Checks (HasDataTypeCreatedCheck(..)) import           Database.Beam.Migrate.SQL.Builder hiding (fromSqlConstraintAttributes) import           Database.Beam.Migrate.Serialization @@ -122,6 +123,7 @@ import           Data.UUID.Types (UUID) import           Data.Word import qualified Data.Vector as V+import           GHC.TypeLits  import qualified Database.PostgreSQL.Simple.ToField as Pg import qualified Database.PostgreSQL.Simple.TypeInfo.Static as Pg@@ -541,7 +543,7 @@                                       (emit "NUMERIC" <> pgOptNumericPrec prec)                                       (numericType prec)   decimalType prec = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.numeric) (mkNumericPrec prec))-                                      (emit "DOUBLE" <> pgOptNumericPrec prec)+                                      (emit "DECIMAL" <> pgOptNumericPrec prec)                                       (decimalType prec)    intType = PgDataTypeSyntax (PgDataTypeDescrOid (Pg.typoid Pg.int4) Nothing) (emit "INT") intType@@ -1177,13 +1179,11 @@ DEFAULT_SQL_SYNTAX(Bool) DEFAULT_SQL_SYNTAX(Double) DEFAULT_SQL_SYNTAX(Float)-DEFAULT_SQL_SYNTAX(Int) DEFAULT_SQL_SYNTAX(Int8) DEFAULT_SQL_SYNTAX(Int16) DEFAULT_SQL_SYNTAX(Int32) DEFAULT_SQL_SYNTAX(Int64) DEFAULT_SQL_SYNTAX(Integer)-DEFAULT_SQL_SYNTAX(Word) DEFAULT_SQL_SYNTAX(Word8) DEFAULT_SQL_SYNTAX(Word16) DEFAULT_SQL_SYNTAX(Word32)@@ -1226,6 +1226,12 @@   sqlValueSyntax = defaultPgValueSyntax . Pg.Binary  instance Pg.ToField a => HasSqlValueSyntax PgValueSyntax (V.Vector a) where+  sqlValueSyntax = defaultPgValueSyntax++instance TypeError (PreferExplicitSize Int Int32) => HasSqlValueSyntax PgValueSyntax Int where+  sqlValueSyntax = defaultPgValueSyntax++instance TypeError (PreferExplicitSize Word Word32) => HasSqlValueSyntax PgValueSyntax Word where   sqlValueSyntax = defaultPgValueSyntax  pgQuotedIdentifier :: T.Text -> PgSyntax

@@ -4,14 +4,20 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}  module Database.Beam.Postgres.Types-  ( Postgres(..) ) where+  ( Postgres(..)+  , fromPgIntegral+  , fromPgScientificOrIntegral+  ) where  import           Database.Beam import           Database.Beam.Backend+import           Database.Beam.Backend.Internal.Compat import           Database.Beam.Migrate.Generics import           Database.Beam.Migrate.SQL (BeamMigrateOnlySqlBackend) import           Database.Beam.Postgres.Syntax@@ -28,6 +34,7 @@ import qualified Data.ByteString.Lazy as BL import           Data.CaseInsensitive (CI) import           Data.Int+import           Data.Proxy import           Data.Ratio (Ratio) import           Data.Scientific (Scientific, toBoundedInteger) import           Data.Tagged@@ -37,11 +44,12 @@ import           Data.UUID.Types (UUID) import           Data.Vector (Vector) import           Data.Word+import           GHC.TypeLits  -- | The Postgres backend type, used to parameterize 'MonadBeam'. See the -- definitions there for more information. The corresponding query monad is -- 'Pg'. See documentation for 'MonadBeam' and the--- <https://tathougies.github/beam/ user guide> for more information on using+-- <https://haskell-beam.github/beam/ user guide> for more information on using -- this backend. data Postgres   = Postgres@@ -49,11 +57,16 @@ instance BeamBackend Postgres where   type BackendFromField Postgres = Pg.FromField +instance HasSqlInTable Postgres where+ instance Pg.FromField SqlNull where   fromField field d = fmap (\Pg.Null -> SqlNull) (Pg.fromField field d) -fromScientificOrIntegral :: (Bounded a, Integral a) => FromBackendRowM Postgres a-fromScientificOrIntegral = do+-- | Deserialize integral fields, possibly downcasting from a larger numeric type+-- via 'Scientific' if we won't lose data, and then falling back to any integral+-- type via 'Integer'+fromPgScientificOrIntegral :: (Bounded a, Integral a) => FromBackendRowM Postgres a+fromPgScientificOrIntegral = do   sciVal <- fmap (toBoundedInteger =<<) peekField   case sciVal of     Just sciVal' -> do@@ -83,24 +96,28 @@ instance FromBackendRow Postgres Bool instance FromBackendRow Postgres Char instance FromBackendRow Postgres Double-instance FromBackendRow Postgres Int where-  fromBackendRow = fromPgIntegral instance FromBackendRow Postgres Int16 where   fromBackendRow = fromPgIntegral instance FromBackendRow Postgres Int32 where   fromBackendRow = fromPgIntegral instance FromBackendRow Postgres Int64 where   fromBackendRow = fromPgIntegral++instance TypeError (PreferExplicitSize Int Int32) => FromBackendRow Postgres Int where+  fromBackendRow = fromPgIntegral+ -- Word values are serialized as SQL @NUMBER@ types to guarantee full domain coverage.--- However, we wan them te be serialized/deserialized as whichever type makes sense-instance FromBackendRow Postgres Word where-  fromBackendRow = fromScientificOrIntegral+-- However, we want them te be serialized/deserialized as whichever type makes sense instance FromBackendRow Postgres Word16 where-  fromBackendRow = fromScientificOrIntegral+  fromBackendRow = fromPgScientificOrIntegral instance FromBackendRow Postgres Word32 where-  fromBackendRow = fromScientificOrIntegral+  fromBackendRow = fromPgScientificOrIntegral instance FromBackendRow Postgres Word64 where-  fromBackendRow = fromScientificOrIntegral+  fromBackendRow = fromPgScientificOrIntegral++instance TypeError (PreferExplicitSize Word Word32) => FromBackendRow Postgres Word where+  fromBackendRow = fromPgScientificOrIntegral+ instance FromBackendRow Postgres Integer instance FromBackendRow Postgres ByteString instance FromBackendRow Postgres Scientific@@ -168,10 +185,24 @@ instance HasDefaultSqlDataType Postgres LocalTime where   defaultSqlDataType _ _ _ = timestampType Nothing False -instance HasDefaultSqlDataType Postgres (SqlSerial Int) where+instance HasDefaultSqlDataType Postgres UTCTime where+  defaultSqlDataType _ _ _ = timestampType Nothing True++instance HasDefaultSqlDataType Postgres (SqlSerial Int16) where+  defaultSqlDataType _ _ False = pgSmallSerialType+  defaultSqlDataType _ _ _ = smallIntType++instance HasDefaultSqlDataType Postgres (SqlSerial Int32) where   defaultSqlDataType _ _ False = pgSerialType   defaultSqlDataType _ _ _ = intType +instance HasDefaultSqlDataType Postgres (SqlSerial Int64) where+  defaultSqlDataType _ _ False = pgBigSerialType+  defaultSqlDataType _ _ _ = bigIntType++instance TypeError (PreferExplicitSize Int Int32) => HasDefaultSqlDataType Postgres (SqlSerial Int) where+  defaultSqlDataType _ = defaultSqlDataType (Proxy @(SqlSerial Int32))+ instance HasDefaultSqlDataType Postgres UUID where   defaultSqlDataType _ _ _ = pgUuidType @@ -184,13 +215,11 @@ PG_HAS_EQUALITY_CHECK(Bool) PG_HAS_EQUALITY_CHECK(Double) PG_HAS_EQUALITY_CHECK(Float)-PG_HAS_EQUALITY_CHECK(Int) PG_HAS_EQUALITY_CHECK(Int8) PG_HAS_EQUALITY_CHECK(Int16) PG_HAS_EQUALITY_CHECK(Int32) PG_HAS_EQUALITY_CHECK(Int64) PG_HAS_EQUALITY_CHECK(Integer)-PG_HAS_EQUALITY_CHECK(Word) PG_HAS_EQUALITY_CHECK(Word8) PG_HAS_EQUALITY_CHECK(Word16) PG_HAS_EQUALITY_CHECK(Word32)@@ -219,6 +248,11 @@ PG_HAS_EQUALITY_CHECK(Vector a) PG_HAS_EQUALITY_CHECK(CI Text) PG_HAS_EQUALITY_CHECK(CI TL.Text)++instance TypeError (PreferExplicitSize Int Int32) => HasSqlEqualityCheck Postgres Int+instance TypeError (PreferExplicitSize Int Int32) => HasSqlQuantifiedEqualityCheck Postgres Int+instance TypeError (PreferExplicitSize Word Word32) => HasSqlEqualityCheck Postgres Word+instance TypeError (PreferExplicitSize Word Word32) => HasSqlQuantifiedEqualityCheck Postgres Word  instance HasSqlEqualityCheck Postgres a =>   HasSqlEqualityCheck Postgres (Tagged t a)

@@ -1,8 +1,8 @@ name:                 beam-postgres-version:              0.4.0.0+version:              0.5.0.0 synopsis:             Connection layer between beam and postgres description:          Beam driver for <https://www.postgresql.org/ PostgreSQL>, an advanced open-source RDBMS-homepage:             http://tathougies.github.io/beam/user-guide/backends/beam-postgres+homepage:             https://haskell-beam.github.io/beam/user-guide/backends/beam-postgres license:              MIT license-file:         LICENSE author:               Travis Athougies@@ -11,27 +11,30 @@ build-type:           Simple cabal-version:        1.18 extra-doc-files:      ChangeLog.md-bug-reports:          https://github.com/tathougies/beam/issues+bug-reports:          https://github.com/haskell-beam/beam/issues  library   exposed-modules:    Database.Beam.Postgres                       Database.Beam.Postgres.Migrate-                      Database.Beam.Postgres.PgCrypto                       Database.Beam.Postgres.Syntax                       Database.Beam.Postgres.CustomTypes                        Database.Beam.Postgres.Conduit                       Database.Beam.Postgres.Full +                      Database.Beam.Postgres.PgCrypto+                      Database.Beam.Postgres.Extensions.UuidOssp+   other-modules:      Database.Beam.Postgres.Connection                       Database.Beam.Postgres.Debug                       Database.Beam.Postgres.Extensions+                      Database.Beam.Postgres.Extensions.Internal                       Database.Beam.Postgres.PgSpecific                       Database.Beam.Postgres.Types -  build-depends:      base                 >=4.7  && <5.0,-                      beam-core            >=0.8  && <0.9,-                      beam-migrate         >=0.4  && <0.5,+  build-depends:      base                 >=4.9  && <5.0,+                      beam-core            >=0.9  && <0.10,+                      beam-migrate         >=0.5  && <0.6,                        postgresql-libpq     >=0.8  && <0.10,                       postgresql-simple    >=0.5  && <0.7,@@ -40,7 +43,7 @@                       bytestring           >=0.10 && <0.11,                        attoparsec           >=0.13 && <0.14,-                      hashable             >=1.1  && <1.3,+                      hashable             >=1.1  && <1.4,                       lifted-base          >=0.2  && <0.3,                       free                 >=4.12 && <5.2,                       time                 >=1.6  && <1.10,@@ -56,14 +59,14 @@                       unordered-containers >= 0.2 && <0.3,                       tagged               >=0.8  && <0.9, -                      haskell-src-exts     >=1.18 && <1.22+                      haskell-src-exts     >=1.18 && <1.24   default-language:   Haskell2010   default-extensions: ScopedTypeVariables, OverloadedStrings, MultiParamTypeClasses, RankNTypes, FlexibleInstances,                       DeriveDataTypeable, DeriveGeneric, StandaloneDeriving, TypeFamilies, GADTs, OverloadedStrings,                       CPP, TypeApplications, FlexibleContexts   ghc-options:        -Wall   if flag(werror)-    ghc-options:       -Werror+    ghc-options: -Werror  test-suite beam-postgres-tests   type: exitcode-stdio-1.0@@ -74,8 +77,21 @@                  Database.Beam.Postgres.Test.Select,                  Database.Beam.Postgres.Test.DataTypes,                  Database.Beam.Postgres.Test.Migrate-  build-depends: base, beam-core, beam-migrate, beam-postgres, text, bytestring, tasty, tasty-hunit,-                 postgresql-simple, process, temporary, hedgehog, uuid, filepath, directory+  build-depends:+    aeson,+    base,+    beam-core,+    beam-migrate,+    beam-postgres,+    bytestring,+    hedgehog,+    postgresql-simple,+    tasty-hunit,+    tasty,+    text,+    tmp-postgres,+    uuid,+    vector   default-language: Haskell2010   default-extensions: OverloadedStrings, FlexibleInstances, FlexibleContexts, TypeFamilies,                       ScopedTypeVariables, MultiParamTypeClasses, TypeApplications, DeriveGeneric,@@ -88,5 +104,5 @@  source-repository head   type: git-  location: https://github.com/tathougies/beam.git+  location: https://github.com/haskell-beam/beam.git   subdir: beam-postgres

@@ -7,8 +7,7 @@  import qualified Database.PostgreSQL.Simple as Pg -import           Control.Exception (SomeException(..), bracket, catch)-import           Control.Concurrent (threadDelay)+import           Control.Exception (bracket)  import           Control.Monad (void) #if MIN_VERSION_base(4,12,0)@@ -16,16 +15,10 @@ #endif  import           Data.ByteString (ByteString)-import           Data.Semigroup import           Data.String  import qualified Hedgehog -import           System.IO.Temp-import           System.Process-import           System.Exit-import           System.FilePath-import           System.Directory  withTestPostgres :: String -> IO ByteString -> (Pg.Connection -> IO a) -> IO a withTestPostgres dbName getConnStr action = do@@ -38,51 +31,22 @@       withTemplate1 = bracket (Pg.connectPostgreSQL connStrTemplate1) Pg.close        createDatabase = withTemplate1 $ \c -> do-                         Pg.execute_ c (fromString ("CREATE DATABASE " <> dbName))+                         void $ Pg.execute_ c (fromString ("CREATE DATABASE " <> dbName))                           Pg.connectPostgreSQL connStrDb       dropDatabase c = do         Pg.close c-        withTemplate1 $ \c' -> do-            Pg.execute_ c' (fromString ("DROP DATABASE " <> dbName))-            pure ()+        withTemplate1 $ \c' -> void $+          Pg.execute_ c' (fromString ("DROP DATABASE " <> dbName))    bracket createDatabase dropDatabase action -startTempPostgres :: IO (ByteString, IO ())-startTempPostgres = do-  tmpDir <- getCanonicalTemporaryDirectory-  pgDataDir <- createTempDirectory tmpDir "postgres-data"--  callProcess "pg_ctl" [ "init", "-D", pgDataDir ]--  -- Use 'D' because otherwise, the path is too long on OS X-  pgHdl <- spawnProcess "postgres"-                        [ "-D", pgDataDir-                        , "-k", pgDataDir, "-h", "" ]--  putStrLn ("Using " ++ pgDataDir ++ " as postgres host")--  let waitForPort 10 = fail "Could not connect to postgres"-      waitForPort n = do-        (code, stdout, stderr) <- readProcessWithExitCode "pg_ctl" [ "status", "-D", pgDataDir ] ""-        case code of-          ExitSuccess -> waitForSocket 0-          ExitFailure _ -> threadDelay 1000000 >> waitForPort (n + 1)--      waitForSocket 10 = fail "Could not connect to postgres (waitForSocket)"-      waitForSocket n = do-        skExists <- doesFileExist (pgDataDir </> ".s.PGSQL.5432")-        if skExists then pure () else threadDelay 1000000 >> waitForSocket (n + 1)--  waitForPort 0-  putStrLn "Completed waiting for postgres"--  pure ( fromString ("host=" ++ pgDataDir)-       , void (callProcess "pg_ctl" [ "stop", "-D", pgDataDir ]))- #if MIN_VERSION_base(4,12,0)+#if !MIN_VERSION_hedgehog(1,0,0) -- TODO orphan instances are bad+-- Would be easier to say 'build-depends: hedgehog >= 1.0',+-- but it's difficult to propagate to older Stackage snapshots instance Monad m => MonadFail (Hedgehog.PropertyT m) where     fail _ = Hedgehog.failure+#endif #endif

@@ -4,7 +4,6 @@  import Database.Beam import Database.Beam.Postgres-import Database.Beam.Postgres.Migrate import Database.Beam.Postgres.Test import Database.Beam.Migrate import Database.Beam.Backend.SQL.BeamExtensions@@ -12,6 +11,7 @@ import Control.Exception (SomeException(..), handle)  import Data.ByteString (ByteString)+import Data.Int import Data.Text (Text)  import Test.Tasty@@ -25,12 +25,12 @@  data JsonT f     = JsonT-    { _key :: C f Int+    { _key :: C f Int32     , _field1 :: C f (PgJSON String) }     deriving (Generic, Beamable)  instance Table JsonT where-    data PrimaryKey JsonT f = JsonKey (C f Int)+    data PrimaryKey JsonT f = JsonKey (C f Int32)       deriving (Generic, Beamable)     primaryKey = JsonKey <$> _key @@ -39,7 +39,7 @@     { jsonTable :: entity (TableEntity JsonT) }     deriving (Generic, Database Postgres) --- | Regression test for <https://github.com/tathougies/beam/issues/297 #297>+-- | Regression test for <https://github.com/haskell-beam/beam/issues/297 #297> jsonNulTest :: IO ByteString -> TestTree jsonNulTest pgConn =     testCase "JSON NUL handling (#297)" $@@ -68,7 +68,7 @@           fmap (fmap (\(PgJSON v) -> v)) $             runSelectReturningList $ select $             fmap (\(JsonT _ v) -> v) $-            orderBy_ (\(JsonT pk _) -> asc_ pk) $+            orderBy_ (\(JsonT k _) -> asc_ k) $             all_ (jsonTable db)        readback @?= [ "hello\0world"@@ -81,23 +81,23 @@       return ()  data TblT f-    = Tbl { _tblKey :: C f Int, _tblValue :: C f Text }+    = Tbl { _tblKey :: C f Int32, _tblValue :: C f Text }       deriving (Generic, Beamable)  deriving instance Show (TblT Identity) deriving instance Eq (TblT Identity)  instance Table TblT where-    data PrimaryKey TblT f = TblKey (C f Int)+    data PrimaryKey TblT f = TblKey (C f Int32)       deriving (Generic, Beamable)     primaryKey = TblKey <$> _tblKey  data WrongTblT f-    = WrongTbl { _wrongTblKey :: C f Int, _wrongTblValue :: C f Int }+    = WrongTbl { _wrongTblKey :: C f Int32, _wrongTblValue :: C f Int32 }       deriving (Generic, Beamable)  instance Table WrongTblT where-    data PrimaryKey WrongTblT f = WrongTblKey (C f Int)+    data PrimaryKey WrongTblT f = WrongTblKey (C f Int32)       deriving (Generic, Beamable)     primaryKey = WrongTblKey <$> _wrongTblKey @@ -109,7 +109,7 @@     = WrongDb { _wrongTbl :: entity (TableEntity WrongTblT) }       deriving (Generic, Database Postgres) --- | Regression test for <https://github.com/tathougies/beam/issues/112>+-- | Regression test for <https://github.com/haskell-beam/beam/issues/112> errorOnSchemaMismatch :: IO ByteString -> TestTree errorOnSchemaMismatch pgConn =     testCase "runInsertReturningList should error on schema mismatch (#112)" $@@ -129,7 +129,7 @@                                                         (WrongTbl (field "key" int notNull)                                                                   (field "value" int notNull))) -      didFail <- handle (\(e :: SomeException) -> pure True) $+      didFail <- handle (\(_ :: SomeException) -> pure True) $         runBeamPostgres conn $ do           _ <- runInsertReturningList $ insert (_wrongTbl wrongDb) $ insertValues [ WrongTbl 4 23, WrongTbl 5 24, WrongTbl 6 24 ]           pure False

@@ -9,15 +9,12 @@ import           Database.Beam.Postgres import           Database.Beam.Postgres.Migrate (migrationBackend) import           Database.Beam.Postgres.Test-import qualified Database.PostgreSQL.Simple as Pg  import           Data.ByteString (ByteString) import           Data.Functor.Classes import           Data.Int import           Data.Proxy (Proxy(..))-import           Data.Semigroup import qualified Data.Text as T-import qualified Data.Text.Lazy as TL import           Data.Typeable import           Data.UUID (UUID, fromWords) import           Data.Word@@ -32,6 +29,9 @@  import           Unsafe.Coerce +textGen :: Hedgehog.Gen T.Text+textGen = Gen.text (Range.constant 0 1000) $ Gen.filter (/= '\NUL') Gen.unicode+ uuidGen :: Hedgehog.Gen UUID uuidGen = fromWords <$> Gen.integral Range.constantBounded                     <*> Gen.integral Range.constantBounded@@ -72,7 +72,7 @@     , marshalTest (Gen.integral (Range.constantBounded @Word16)) postgresConn     , marshalTest (Gen.integral (Range.constantBounded @Word32)) postgresConn     , marshalTest (Gen.integral (Range.constantBounded @Word64)) postgresConn-    , marshalTest (Gen.text (Range.constant 0 1000) Gen.unicode) postgresConn+    , marshalTest textGen postgresConn     , marshalTest uuidGen postgresConn      , marshalTest' (\a b -> Hedgehog.assert (ptCmp a b))  pointGen postgresConn@@ -85,7 +85,7 @@     , marshalTest (Gen.maybe (Gen.integral (Range.constantBounded @Word16))) postgresConn     , marshalTest (Gen.maybe (Gen.integral (Range.constantBounded @Word32))) postgresConn     , marshalTest (Gen.maybe (Gen.integral (Range.constantBounded @Word64))) postgresConn-    , marshalTest (Gen.maybe (Gen.text (Range.constant 0 1000) Gen.unicode)) postgresConn+    , marshalTest (Gen.maybe textGen) postgresConn     , marshalTest (Gen.maybe uuidGen) postgresConn      , marshalTest' (\a b -> Hedgehog.assert (liftEq ptCmp a b))  (Gen.maybe pointGen) postgresConn@@ -104,13 +104,13 @@  data MarshalTable a f     = MarshalTable-    { _marshalTableId    :: C f (SqlSerial Int)+    { _marshalTableId    :: C f (SqlSerial Int32)     , _marshalTableEntry :: C f a     } deriving (Generic) instance Beamable (MarshalTable a)  instance Typeable a => Table (MarshalTable a) where-    data PrimaryKey (MarshalTable a) f = MarshalTableKey (C f (SqlSerial Int))+    data PrimaryKey (MarshalTable a) f = MarshalTableKey (C f (SqlSerial Int32))       deriving (Generic, Beamable)     primaryKey = MarshalTableKey . _marshalTableId 

@@ -3,6 +3,7 @@ import Database.Beam import Database.Beam.Postgres import Database.Beam.Postgres.Migrate+import Database.Beam.Postgres.PgCrypto (PgCrypto) import Database.Beam.Postgres.Test import Database.Beam.Migrate import Database.Beam.Migrate.Simple@@ -20,6 +21,7 @@       , charNoWidthVerification postgresConn "VARCHAR" varchar       , charWidthVerification postgresConn "CHAR" char       , charNoWidthVerification postgresConn "CHAR" char+      , extensionVerification postgresConn       ]  data CharT f@@ -37,6 +39,11 @@     { vcTbl :: entity (TableEntity CharT) }     deriving (Generic, Database Postgres) +data CryptoDb entity+    = CryptoDb+    { cryptoExtension :: entity (PgExtensionEntity PgCrypto) }+    deriving (Generic, Database Postgres)+ -- | Verifies that 'verifySchema' correctly checks the width of -- @VARCHAR@ or @CHAR@ columns. charWidthVerification :: IO ByteString -> String -> (Maybe Word -> DataType Postgres Text) -> TestTree@@ -68,5 +75,24 @@           res <- verifySchema migrationBackend db            case res of+            VerificationSucceeded -> return ()+            VerificationFailed failures -> fail ("Verification failed: " ++ show failures)++-- | Verifies that 'verifySchema' correctly checks enabled PgCrypto extension+extensionVerification :: IO ByteString -> TestTree+extensionVerification pgConn =+    testCase "verifySchema correctly checks enabled PgCrypto extension" $+      withTestPostgres "db_extension_pgcrypto" pgConn $ \conn ->+        runBeamPostgres conn $ do+          let migration = CryptoDb <$> pgCreateExtension+          dbBefore <- executeMigration (const $ return ()) migration+          resBefore <- verifySchema migrationBackend dbBefore+          case resBefore of+            VerificationSucceeded -> fail "Verification succeeded before migration when it should have failed"+            VerificationFailed _ -> return ()++          dbAfter <- executeMigration runNoReturn migration+          resAfter <- verifySchema migrationBackend dbAfter+          case resAfter of             VerificationSucceeded -> return ()             VerificationFailed failures -> fail ("Verification failed: " ++ show failures)

@@ -1,36 +1,105 @@-module Database.Beam.Postgres.Test.Select where+{-# LANGUAGE LambdaCase #-} +module Database.Beam.Postgres.Test.Select (tests) where++import           Data.Aeson+import           Data.ByteString (ByteString)+import           Data.Int+import           Data.Text (Text)+import qualified Data.Vector as V+import           Test.Tasty+import           Test.Tasty.HUnit+import           Data.UUID (UUID, nil)+ import           Database.Beam-import           Database.Beam.Backend.SQL-import           Database.Beam.Backend.SQL.BeamExtensions+import           Database.Beam.Backend.SQL.SQL92 import           Database.Beam.Migrate-import           Database.Beam.Migrate.Simple (autoMigrate) import           Database.Beam.Postgres-import           Database.Beam.Postgres.Migrate (migrationBackend)+import           Database.Beam.Postgres.Extensions.UuidOssp+ import           Database.Beam.Postgres.Test-import qualified Database.PostgreSQL.Simple as Pg -import           Data.ByteString (ByteString)-import           Data.Functor.Classes-import           Data.Int-import           Data.Proxy (Proxy(..))-import           Data.Semigroup-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL-import           Data.Typeable-import           Data.UUID (UUID, fromWords)-import           Data.Word+tests :: IO ByteString -> TestTree+tests getConn = testGroup "Selection Tests"+  [ testGroup "JSON"+      [ testPgArrayToJSON getConn+      ]+  , testGroup "UUID"+      [ testUuidFunction getConn "uuid_nil" pgUuidNil+      , testUuidFunction getConn "uuid_ns_dns" pgUuidNsDns+      , testUuidFunction getConn "uuid_ns_url" pgUuidNsUrl+      , testUuidFunction getConn "uuid_ns_oid" pgUuidNsOid+      , testUuidFunction getConn "uuid_ns_x500" pgUuidNsX500+      , testUuidFunction getConn "uuid_generate_v1" pgUuidGenerateV1+      , testUuidFunction getConn "uuid_generate_v1mc" pgUuidGenerateV1Mc+      , testUuidFunction getConn "uuid_generate_v3" $ \ext ->+          pgUuidGenerateV3 ext (val_ nil) "nil"+      , testUuidFunction getConn "uuid_generate_v4" pgUuidGenerateV4+      , testUuidFunction getConn "uuid_generate_v5" $ \ext ->+          pgUuidGenerateV5 ext (val_ nil) "nil"+      ]+  , testInRowValues getConn+  , testReturningMany getConn+  ] -import qualified Hedgehog-import           Hedgehog ((===))-import qualified Hedgehog.Gen as Gen-import qualified Hedgehog.Range as Range+testPgArrayToJSON :: IO ByteString -> TestTree+testPgArrayToJSON getConn = testFunction getConn "array_to_json" $ \conn -> do+  let values :: [Int32] = [1, 2, 3]+  actual :: [PgJSON Value] <-+    runBeamPostgres conn $ runSelectReturningList $ select $+      return $ pgArrayToJson $ val_ $ V.fromList values+  assertEqual "JSON list" [PgJSON $ toJSON values] actual -import           Test.Tasty-import           Test.Tasty.HUnit+data UuidSchema f = UuidSchema+  { _uuidOssp :: f (PgExtensionEntity UuidOssp)+  } deriving (Generic, Database Postgres) -import           Unsafe.Coerce+testUuidFunction+  :: IO ByteString+  -> String+  -> (forall s. UuidOssp -> QExpr Postgres s UUID)+  -> TestTree+testUuidFunction getConn name mkUuid = testFunction getConn name $ \conn ->+  runBeamPostgres conn $ do+    db <- executeMigration runNoReturn $ UuidSchema <$>+      pgCreateExtension @UuidOssp+    [_] <- runSelectReturningList $ select $+      return $ mkUuid $ getPgExtension $ _uuidOssp $ unCheckDatabase db+    return () -tests :: IO ByteString -> TestTree-tests postgresConn =-    testGroup "Postgres Select Tests" []+data Pair f = Pair+  { _left :: C f Bool+  , _right :: C f Bool+  } deriving (Generic, Beamable)++testInRowValues :: IO ByteString -> TestTree+testInRowValues getConn = testCase "IN with row values works" $+  withTestPostgres "db_in_row_values" getConn $ \conn -> do+    result <- runBeamPostgres conn $ runSelectReturningList $ select $ do+      let p :: forall ctx s. Pair (QGenExpr ctx Postgres s)+          p = val_ $ Pair False False+      return $ p `in_` [p, p]+    assertEqual "result" [True] result++testReturningMany :: IO ByteString -> TestTree+testReturningMany getConn = testCase "runReturningMany (batching via cursor) works" $+  withTestPostgres "run_returning_many_cursor" getConn $ \conn -> do+    result <- runBeamPostgres conn $ runSelectReturningMany+      (select $ pgUnnestArray $ array_ $ (as_ @Int32 . val_) <$> [0..rowCount - 1])+      (\fetch ->+        let count n = fetch >>= \case+              Nothing -> pure n+              Just _  -> count (n + 1)+        in count 0)+    assertEqual "result" rowCount result+ where+  rowCount = 500+  runSelectReturningMany ::+    (FromBackendRow Postgres x) =>+    SqlSelect Postgres x -> (Pg (Maybe x) -> Pg a) -> Pg a+  runSelectReturningMany (SqlSelect s) =+    runReturningMany (selectCmd s)++testFunction :: IO ByteString -> String -> (Connection -> Assertion) -> TestTree+testFunction getConn name mkAssertion = testCase name $+  withTestPostgres name getConn mkAssertion

@@ -1,17 +1,23 @@ module Main where +import qualified Database.Postgres.Temp as TempDb import Test.Tasty -import Database.Beam.Postgres.Test (startTempPostgres) import qualified Database.Beam.Postgres.Test.Select as Select import qualified Database.Beam.Postgres.Test.Marshal as Marshal import qualified Database.Beam.Postgres.Test.DataTypes as DataType import qualified Database.Beam.Postgres.Test.Migrate as Migrate  main :: IO ()-main = defaultMain (withResource startTempPostgres snd $ \getConnStr ->-                    testGroup "beam-postgres tests"-                              [ Marshal.tests (fst <$> getConnStr)-                              , Select.tests  (fst <$> getConnStr)-                              , DataType.tests (fst <$> getConnStr)-                              , Migrate.tests (fst <$> getConnStr) ])+main = defaultMain $ withDb $ \getDb ->+  let getConnStr = TempDb.toConnectionString <$> getDb+  in testGroup "beam-postgres tests"+      [ Marshal.tests getConnStr+      , Select.tests getConnStr+      , DataType.tests getConnStr+      , Migrate.tests getConnStr+      ]+  where+    withDb = withResource+      (either (\e -> error $ "Failed to start DB: " <> show e) pure =<< TempDb.startConfig mempty)+      TempDb.stop