diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/Database/Beam/Postgres.hs b/Database/Beam/Postgres.hs --- a/Database/Beam/Postgres.hs +++ b/Database/Beam/Postgres.hs @@ -15,11 +15,11 @@ -- . -- -- For examples on how to use @beam-postgres@ usage, see --- . +-- . 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 diff --git a/Database/Beam/Postgres/Conduit.hs b/Database/Beam/Postgres/Conduit.hs --- a/Database/Beam/Postgres/Conduit.hs +++ b/Database/Beam/Postgres/Conduit.hs @@ -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' diff --git a/Database/Beam/Postgres/Connection.hs b/Database/Beam/Postgres/Connection.hs --- a/Database/Beam/Postgres/Connection.hs +++ b/Database/Beam/Postgres/Connection.hs @@ -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 diff --git a/Database/Beam/Postgres/Debug.hs b/Database/Beam/Postgres/Debug.hs --- a/Database/Beam/Postgres/Debug.hs +++ b/Database/Beam/Postgres/Debug.hs @@ -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) diff --git a/Database/Beam/Postgres/Extensions.hs b/Database/Beam/Postgres/Extensions.hs --- a/Database/Beam/Postgres/Extensions.hs +++ b/Database/Beam/Postgres/Extensions.hs @@ -39,7 +39,7 @@ -- database, -- -- @ --- import Database.Beam.Migrate.PgCrypto +-- import Database.Beam.Postgres.PgCrypto -- -- data MyDatabase entity -- = MyDatabase diff --git a/Database/Beam/Postgres/Extensions/Internal.hs b/Database/Beam/Postgres/Extensions/Internal.hs new file mode 100644 --- /dev/null +++ b/Database/Beam/Postgres/Extensions/Internal.hs @@ -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 diff --git a/Database/Beam/Postgres/Extensions/UuidOssp.hs b/Database/Beam/Postgres/Extensions/UuidOssp.hs new file mode 100644 --- /dev/null +++ b/Database/Beam/Postgres/Extensions/UuidOssp.hs @@ -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] + } diff --git a/Database/Beam/Postgres/Full.hs b/Database/Beam/Postgres/Full.hs --- a/Database/Beam/Postgres/Full.hs +++ b/Database/Beam/Postgres/Full.hs @@ -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 --- for usage +-- 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 --- +-- -- -- 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 -- . 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 --- 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 --- 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 + -- 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 + -- 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 " " diff --git a/Database/Beam/Postgres/Migrate.hs b/Database/Beam/Postgres/Migrate.hs --- a/Database/Beam/Postgres/Migrate.hs +++ b/Database/Beam/Postgres/Migrate.hs @@ -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 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 diff --git a/Database/Beam/Postgres/PgCrypto.hs b/Database/Beam/Postgres/PgCrypto.hs --- a/Database/Beam/Postgres/PgCrypto.hs +++ b/Database/Beam/Postgres/PgCrypto.hs @@ -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" diff --git a/Database/Beam/Postgres/PgSpecific.hs b/Database/Beam/Postgres/PgSpecific.hs --- a/Database/Beam/Postgres/PgSpecific.hs +++ b/Database/Beam/Postgres/PgSpecific.hs @@ -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 @@>@ and @<@@ 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 -- . diff --git a/Database/Beam/Postgres/Syntax.hs b/Database/Beam/Postgres/Syntax.hs --- a/Database/Beam/Postgres/Syntax.hs +++ b/Database/Beam/Postgres/Syntax.hs @@ -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 diff --git a/Database/Beam/Postgres/Types.hs b/Database/Beam/Postgres/Types.hs --- a/Database/Beam/Postgres/Types.hs +++ b/Database/Beam/Postgres/Types.hs @@ -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 --- for more information on using +-- 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) diff --git a/beam-postgres.cabal b/beam-postgres.cabal --- a/beam-postgres.cabal +++ b/beam-postgres.cabal @@ -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 , 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 diff --git a/test/Database/Beam/Postgres/Test.hs b/test/Database/Beam/Postgres/Test.hs --- a/test/Database/Beam/Postgres/Test.hs +++ b/test/Database/Beam/Postgres/Test.hs @@ -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 diff --git a/test/Database/Beam/Postgres/Test/DataTypes.hs b/test/Database/Beam/Postgres/Test/DataTypes.hs --- a/test/Database/Beam/Postgres/Test/DataTypes.hs +++ b/test/Database/Beam/Postgres/Test/DataTypes.hs @@ -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 +-- | Regression test for 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 +-- | Regression test for 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 diff --git a/test/Database/Beam/Postgres/Test/Marshal.hs b/test/Database/Beam/Postgres/Test/Marshal.hs --- a/test/Database/Beam/Postgres/Test/Marshal.hs +++ b/test/Database/Beam/Postgres/Test/Marshal.hs @@ -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 diff --git a/test/Database/Beam/Postgres/Test/Migrate.hs b/test/Database/Beam/Postgres/Test/Migrate.hs --- a/test/Database/Beam/Postgres/Test/Migrate.hs +++ b/test/Database/Beam/Postgres/Test/Migrate.hs @@ -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) diff --git a/test/Database/Beam/Postgres/Test/Select.hs b/test/Database/Beam/Postgres/Test/Select.hs --- a/test/Database/Beam/Postgres/Test/Select.hs +++ b/test/Database/Beam/Postgres/Test/Select.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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