diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,81 @@ +3.6.0.0 +======= +- @parsonsmatt + - [#422](https://github.com/bitemyapp/esqueleto/pull/422) + - The instance of `HasField` for `SqlExpr (Maybe (Entity a))` joins + `Maybe` values together. This means that if you `leftJoin` a table + with a `Maybe` column, the result will be a `SqlExpr (Value (Maybe + typ))`, instead of `SqlExpr (Value (Maybe (Maybe typ)))`. + - To make this a less breaking change, `joinV` has been given a similar + behavior. If the input type to `joinV` is `Maybe (Maybe typ)`, then + the result becomes `Maybe typ`. If the input type is `Maybe typ`, then + the output is also `Maybe typ`. The `joinV'` function is given as an + alternative with monomorphic behavior. + - The `just` function is also modified to avoid nesting `Maybe`. + Likewise, `just'` is provided to give monomorphic behavior. + - `subSelect`, `max_`, `min_`, and `coalesce` were all + given `Nullable` output types as well. This should help to reduce the + incidence of nested `Maybe`. + - The operator `??.` was introduced which can do nested `Maybe`. You may + want this if you have type inference issues with `?.` combining + `Maybe`. + - [#420](https://github.com/bitemyapp/esqueleto/pull/420) + - Add a fixity declaration to `?.` + - [#412](https://github.com/bitemyapp/esqueleto/pull/412) + - The `random_` and `rand` functions (deprecated in 2.6.0) have been + removed. Please refer to the database specific ones (ie + `Database.Esqueleto.PostgreSQL` etc) + - The `sub_select` function (deprecated in 3.2.0) has been removed. + Please use the safer variants like `subSelect`, `subSelectMaybe`, etc. + - The `ToAliasT` and `ToAliasReferenceT` types has been removed after having been deprecated in 3.4.0.1. + - The `Union` type (deprecated in 3.4) was removed. Please use `union_` + instead. + - The `UnionAll` type (deprecated in 3.4) was removed. Please use + `unionAll_` instead. + - The `Except` type (deprecated in 3.4) was removed. Please use + `except_` instead. + - The `Intersect` type (deprecated in 3.4) was removed. Please use + `intersect_` instead. + - The `SubQuery` type (deprecated in 3.4) was removed. You do not need + to tag subqueries to use them in `from` clauses. + - The `SelectQuery` type (deprecated in 3.4) was removed. You do not + need to tag `SqlQuery` values with `SelectQuery`. + - [#287](https://github.com/bitemyapp/esqueleto/pull/278) + - Deprecate `distinctOn` and `distinctOnOrderBy`. Use the variants + defined in `PostgreSQL` module instead. The signature has changed, but + the refactor is straightforward: + ``` + -- old: + p <- from $ table + distinctOn [don x] $ do + pure p + + -- new: + p <- from $ table + distinctOn [don x] + pure p + ``` + - [#301](https://github.com/bitemyapp/esqueleto/pull/301) + - Postgresql `upsert` and `upsertBy` now require a `NonEmpty` list of + updates. If you want to provide an empty list of updates, you'll need + to use `upsertMaybe` and `upsertMaybeBe` instead. Postgres does not + return rows from the database if no updates are performed. + - [#413](https://github.com/bitemyapp/esqueleto/pull/413) + - The ability to `coerce` `SqlExpr` was removed. Instead, use + `veryUnsafeCoerceSqlExpr`. See the documentation on + `veryUnsafeCoerceSqlExpr` for safe use example. + - `unsafeCeorceSqlExpr` is provided as an option when the underlying + Haskell types are coercible. This is still unsafe, as different + `PersistFieldSql` instances may be at play. + - [#420](https://github.com/bitemyapp/esqueleto/pull/421) + - The `LockingKind` constructors are deprecated, and will be removed + from non-Internal modules in a future release. Smart constructors + replace them, and you may need to import them from a different + database-specific module. + - [#425](https://github.com/bitemyapp/esqueleto/pull/425) + - `fromBaseId` is introduced as the inverse of `toBaseId`. + - `toBaseIdMaybe` and `fromBaseIdMaybe` are introduced. + 3.5.14.0 ======== - @parsonsmatt diff --git a/esqueleto.cabal b/esqueleto.cabal --- a/esqueleto.cabal +++ b/esqueleto.cabal @@ -1,8 +1,7 @@ cabal-version: 1.12 name: esqueleto - -version: 3.5.14.0 +version: 3.6.0.0 synopsis: Type-safe EDSL for SQL queries on persistent backends. description: @esqueleto@ is a bare bones, type-safe EDSL for SQL queries that works with unmodified @persistent@ SQL backends. Its language closely resembles SQL, so you don't have to learn new concepts, just new syntax, and it's fairly easy to predict the generated SQL and optimize it for your backend. Most kinds of errors committed when writing SQL are caught as compile-time errors---although it is possible to write type-checked @esqueleto@ queries that fail at runtime. . @@ -53,7 +52,7 @@ hs-source-dirs: src/ build-depends: - base >=4.8 && <5.0 + base >=4.12 && <5.0 , aeson >=1.0 , attoparsec >= 0.13 && < 0.15 , blaze-html diff --git a/src/Database/Esqueleto.hs b/src/Database/Esqueleto.hs --- a/src/Database/Esqueleto.hs +++ b/src/Database/Esqueleto.hs @@ -51,14 +51,14 @@ -- $gettingstarted -- * @esqueleto@'s Language - where_, on, groupBy, orderBy, rand, asc, desc, limit, offset + where_, on, groupBy, orderBy, asc, desc, limit, offset , distinct, distinctOn, don, distinctOnOrderBy, having, locking - , sub_select, (^.), (?.) - , val, isNothing, just, nothing, joinV, withNonNull + , (^.), (?.) + , val, isNothing, just, just', nothing, joinV, joinV', withNonNull , countRows, count, countDistinct , not_, (==.), (>=.), (>.), (<=.), (<.), (!=.), (&&.), (||.) , between, (+.), (-.), (/.), (*.) - , random_, round_, ceiling_, floor_ + , round_, ceiling_, floor_ , min_, max_, sum_, avg_, castNum, castNumM , coalesce, coalesceDefault , lower_, upper_, trim_, ltrim_, rtrim_, length_, left_, right_ @@ -66,7 +66,7 @@ , subList_select, valList, justList , in_, notIn, exists, notExists , set, (=.), (+=.), (-=.), (*=.), (/=.) - , case_, toBaseId + , case_, toBaseId, fromBaseId, toBaseIdMaybe, fromBaseIdMaybe , subSelect , subSelectMaybe , subSelectCount @@ -83,6 +83,8 @@ , OrderBy , DistinctOn , LockingKind(..) + , forUpdate + , forUpdateSkipLocked , LockableEntity(..) , SqlString -- ** Joins diff --git a/src/Database/Esqueleto/Experimental.hs b/src/Database/Esqueleto/Experimental.hs --- a/src/Database/Esqueleto/Experimental.hs +++ b/src/Database/Esqueleto/Experimental.hs @@ -22,7 +22,6 @@ from , table , Table(..) - , SubQuery(..) , selectQuery -- ** Joins @@ -40,14 +39,9 @@ -- ** Set Operations -- $sql-set-operations , union_ - , Union(..) , unionAll_ - , UnionAll(..) , except_ - , Except(..) , intersect_ - , Intersect(..) - , pattern SelectQuery -- ** Common Table Expressions , with @@ -57,18 +51,16 @@ , From(..) , ToMaybe(..) , ToAlias(..) - , ToAliasT , ToAliasReference(..) - , ToAliasReferenceT , ToSqlSetOperation(..) , SqlSelect + , Nullable -- * The Normal Stuff , where_ , groupBy , groupBy_ , orderBy - , rand , asc , desc , limit @@ -80,8 +72,9 @@ , distinctOnOrderBy , having , locking + , forUpdate + , forUpdateSkipLocked - , sub_select , (^.) , (?.) @@ -113,7 +106,6 @@ , (/.) , (*.) - , random_ , round_ , ceiling_ , floor_ @@ -162,6 +154,9 @@ , case_ , toBaseId + , toBaseIdMaybe + , fromBaseId + , fromBaseIdMaybe , subSelect , subSelectMaybe , subSelectCount diff --git a/src/Database/Esqueleto/Experimental/From.hs b/src/Database/Esqueleto/Experimental/From.hs --- a/src/Database/Esqueleto/Experimental/From.hs +++ b/src/Database/Esqueleto/Experimental/From.hs @@ -98,10 +98,6 @@ ) -{-# DEPRECATED SubQuery "/Since: 3.4.0.0/ - It is no longer necessary to tag 'SqlQuery' values with @SubQuery@" #-} -newtype SubQuery a = SubQuery a -instance (SqlSelect a r, ToAlias a, ToAliasReference a) => ToFrom (SubQuery (SqlQuery a)) a where - toFrom (SubQuery q) = selectQuery q instance (SqlSelect a r, ToAlias a, ToAliasReference a) => ToFrom (SqlQuery a) a where toFrom = selectQuery diff --git a/src/Database/Esqueleto/Experimental/From/SqlSetOperation.hs b/src/Database/Esqueleto/Experimental/From/SqlSetOperation.hs --- a/src/Database/Esqueleto/Experimental/From/SqlSetOperation.hs +++ b/src/Database/Esqueleto/Experimental/From/SqlSetOperation.hs @@ -74,11 +74,6 @@ (_, rightClause) <- unSqlSetOperation (toSqlSetOperation rhs) p pure (leftValue, \info -> leftClause info <> (operation, mempty) <> rightClause info) -{-# DEPRECATED Union "/Since: 3.4.0.0/ - Use the 'union_' function instead of the 'Union' data constructor" #-} -data Union a b = a `Union` b -instance ToSqlSetOperation a a' => ToSqlSetOperation (Union a a) a' where - toSqlSetOperation (Union a b) = union_ a b - -- | Overloaded @union_@ function to support use in both 'SqlSetOperation' -- and 'withRecursive' -- @@ -102,30 +97,10 @@ => UnionAll_ (a -> b -> res) where unionAll_ = mkSetOperation " UNION ALL " -{-# DEPRECATED UnionAll "/Since: 3.4.0.0/ - Use the 'unionAll_' function instead of the 'UnionAll' data constructor" #-} -data UnionAll a b = a `UnionAll` b -instance ToSqlSetOperation a a' => ToSqlSetOperation (UnionAll a a) a' where - toSqlSetOperation (UnionAll a b) = unionAll_ a b - -{-# DEPRECATED Except "/Since: 3.4.0.0/ - Use the 'except_' function instead of the 'Except' data constructor" #-} -data Except a b = a `Except` b -instance ToSqlSetOperation a a' => ToSqlSetOperation (Except a a) a' where - toSqlSetOperation (Except a b) = except_ a b - -- | @EXCEPT@ SQL set operation. Can be used as an infix function between 'SqlQuery' values. except_ :: (ToSqlSetOperation a a', ToSqlSetOperation b a') => a -> b -> SqlSetOperation a' except_ = mkSetOperation " EXCEPT " -{-# DEPRECATED Intersect "/Since: 3.4.0.0/ - Use the 'intersect_' function instead of the 'Intersect' data constructor" #-} -data Intersect a b = a `Intersect` b -instance ToSqlSetOperation a a' => ToSqlSetOperation (Intersect a a) a' where - toSqlSetOperation (Intersect a b) = intersect_ a b - -- | @INTERSECT@ SQL set operation. Can be used as an infix function between 'SqlQuery' values. intersect_ :: (ToSqlSetOperation a a', ToSqlSetOperation b a') => a -> b -> SqlSetOperation a' intersect_ = mkSetOperation " INTERSECT " - -{-# DEPRECATED SelectQuery "/Since: 3.4.0.0/ - It is no longer necessary to tag 'SqlQuery' values with @SelectQuery@" #-} -pattern SelectQuery :: p -> p -pattern SelectQuery a = a - diff --git a/src/Database/Esqueleto/Experimental/ToAlias.hs b/src/Database/Esqueleto/Experimental/ToAlias.hs --- a/src/Database/Esqueleto/Experimental/ToAlias.hs +++ b/src/Database/Esqueleto/Experimental/ToAlias.hs @@ -8,9 +8,6 @@ import Database.Esqueleto.Internal.Internal hiding (From, from, on) import Database.Esqueleto.Internal.PersistentImport -{-# DEPRECATED ToAliasT "This type alias doesn't do anything. Please delete it. Will be removed in the next release." #-} -type ToAliasT a = a - -- Tedious tuple magic class ToAlias a where toAlias :: a -> SqlQuery a diff --git a/src/Database/Esqueleto/Experimental/ToAliasReference.hs b/src/Database/Esqueleto/Experimental/ToAliasReference.hs --- a/src/Database/Esqueleto/Experimental/ToAliasReference.hs +++ b/src/Database/Esqueleto/Experimental/ToAliasReference.hs @@ -5,13 +5,9 @@ module Database.Esqueleto.Experimental.ToAliasReference where -import Data.Coerce import Database.Esqueleto.Internal.Internal hiding (From, from, on) import Database.Esqueleto.Internal.PersistentImport -{-# DEPRECATED ToAliasReferenceT "This type alias doesn't do anything. Please delete it. Will be removed in the next release." #-} -type ToAliasReferenceT a = a - -- more tedious tuple magic class ToAliasReference a where toAliasReference :: Ident -> a -> SqlQuery a @@ -31,7 +27,7 @@ instance ToAliasReference (SqlExpr (Maybe (Entity a))) where toAliasReference aliasSource e = - coerce <$> toAliasReference aliasSource (coerce e :: SqlExpr (Entity a)) + veryUnsafeCoerceSqlExpr <$> toAliasReference aliasSource (veryUnsafeCoerceSqlExpr e :: SqlExpr (Entity a)) instance (ToAliasReference a, ToAliasReference b) => ToAliasReference (a, b) where diff --git a/src/Database/Esqueleto/Experimental/ToMaybe.hs b/src/Database/Esqueleto/Experimental/ToMaybe.hs --- a/src/Database/Esqueleto/Experimental/ToMaybe.hs +++ b/src/Database/Esqueleto/Experimental/ToMaybe.hs @@ -2,14 +2,13 @@ {-# LANGUAGE TypeFamilies #-} module Database.Esqueleto.Experimental.ToMaybe + ( module Database.Esqueleto.Experimental.ToMaybe + , Nullable + ) where import Database.Esqueleto.Internal.Internal hiding (From(..), from, on) import Database.Esqueleto.Internal.PersistentImport (Entity(..)) - -type family Nullable a where - Nullable (Maybe a) = a - Nullable a = a class ToMaybe a where type ToMaybeT a diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/src/Database/Esqueleto/Internal/Internal.hs @@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-} +{-# language AllowAmbiguousTypes #-} +{-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} @@ -35,6 +37,8 @@ -- tracker so we can safely support it. module Database.Esqueleto.Internal.Internal where +import Data.Typeable (TypeRep, typeRep) +import Data.Coerce (Coercible) import Control.Applicative ((<|>)) import Control.Arrow (first, (***)) import Control.Exception (Exception, throw, throwIO) @@ -126,7 +130,7 @@ maybelize :: PreprocessedFrom (SqlExpr (Entity a)) -> PreprocessedFrom (SqlExpr (Maybe (Entity a))) - maybelize (PreprocessedFrom e f') = PreprocessedFrom (coerce e) f' + maybelize (PreprocessedFrom e f') = PreprocessedFrom (veryUnsafeCoerceSqlExpr e) f' -- | (Internal) Do a @JOIN@. fromJoin @@ -362,12 +366,14 @@ distinctOn :: [SqlExpr DistinctOn] -> SqlQuery a -> SqlQuery a distinctOn exprs act = Q (W.tell mempty { sdDistinctClause = DistinctOn exprs }) >> act +{-# DEPRECATED distinctOn "This function is deprecated, as it is only supported in Postgresql. Please use the variant in `Database.Esqueleto.PostgreSQL` instead." #-} + -- | Erase an SqlExpression's type so that it's suitable to -- be used by 'distinctOn'. -- -- @since 2.2.4 don :: SqlExpr (Value a) -> SqlExpr DistinctOn -don = coerce +don = veryUnsafeCoerceSqlExpr -- | A convenience function that calls both 'distinctOn' and -- 'orderBy'. In other words, @@ -401,11 +407,7 @@ $ TLB.toLazyText b , vals ) --- | @ORDER BY random()@ clause. --- --- @since 1.3.10 -rand :: SqlExpr OrderBy -rand = ERaw noMeta $ \_ _ -> ("RANDOM()", []) +{-# DEPRECATED distinctOnOrderBy "This function is deprecated, as it is only supported in Postgresql. Please use the function defined in `Database.Esqueleto.PostgreSQL` instead." #-} -- | @HAVING@. -- @@ -430,29 +432,6 @@ putLocking :: LockingClause -> SqlQuery () putLocking clause = Q $ W.tell mempty { sdLockingClause = clause } -{-# - DEPRECATED - sub_select - "sub_select \n \ -sub_select is an unsafe function to use. If used with a SqlQuery that \n \ -returns 0 results, then it may return NULL despite not mentioning Maybe \n \ -in the return type. If it returns more than 1 result, then it will throw a \n \ -SQL error.\n\n Instead, consider using one of the following alternatives: \n \ -- subSelect: attaches a LIMIT 1 and the Maybe return type, totally safe. \n \ -- subSelectMaybe: Attaches a LIMIT 1, useful for a query that already \n \ - has a Maybe in the return type. \n \ -- subSelectCount: Performs a count of the query - this is always safe. \n \ -- subSelectUnsafe: Performs no checks or guarantees. Safe to use with \n \ - countRows and friends." - #-} --- | Execute a subquery @SELECT@ in an SqlExpression. Returns a --- simple value so should be used only when the @SELECT@ query --- is guaranteed to return just one row. --- --- Deprecated in 3.2.0. -sub_select :: PersistField a => SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value a) -sub_select = sub SELECT - -- | Execute a subquery @SELECT@ in a 'SqlExpr'. The query passed to this -- function will only return a single result - it has a @LIMIT 1@ passed in to -- the query to make it safe, and the return type is 'Maybe' to indicate that @@ -470,9 +449,9 @@ -- -- @since 3.2.0 subSelect - :: PersistField a + :: (PersistField a, NullableFieldProjection a a') => SqlQuery (SqlExpr (Value a)) - -> SqlExpr (Value (Maybe a)) + -> SqlExpr (Value (Maybe a')) subSelect query = just (subSelectUnsafe (query <* limit 1)) -- | Execute a subquery @SELECT@ in a 'SqlExpr'. This function is a shorthand @@ -623,12 +602,28 @@ where_ $ not_ $ isNothing field f $ veryUnsafeCoerceSqlExprValue field +-- | Project an 'EntityField' of a nullable entity. The result type will be +-- 'Nullable', meaning that nested 'Maybe' won't be produced here. +-- +-- As of v3.6.0.0, this will attempt to combine nested 'Maybe'. If you want to +-- keep nested 'Maybe', then see '??.'. +(?.) :: (PersistEntity val , PersistField typ) + => SqlExpr (Maybe (Entity val)) + -> EntityField val typ + -> SqlExpr (Value (Maybe (Nullable typ))) +ent ?. field = veryUnsafeCoerceSqlExprValue (ent ??. field) + -- | Project a field of an entity that may be null. -(?.) :: ( PersistEntity val , PersistField typ) +-- +-- This variant will produce a nested 'Maybe' if you select a 'Maybe' column. +-- If you want to collapse 'Maybe', see '?.'. +-- +-- @since 3.6.0.0 +(??.) :: ( PersistEntity val , PersistField typ) => SqlExpr (Maybe (Entity val)) -> EntityField val typ -> SqlExpr (Value (Maybe typ)) -ERaw m f ?. field = just (ERaw m f ^. field) +ERaw m f ??. field = just (ERaw m f ^. field) -- | Lift a constant value from Haskell-land to the query. val :: PersistField typ => typ -> SqlExpr (Value typ) @@ -680,19 +675,53 @@ -- | Analogous to 'Just', promotes a value of type @typ@ into -- one of type @Maybe typ@. It should hold that @'val' . Just -- === just . 'val'@. -just :: SqlExpr (Value typ) -> SqlExpr (Value (Maybe typ)) +-- +-- This function will try not to produce a nested 'Maybe'. This is in accord +-- with how SQL represents @NULL@. That means that @'just' . 'just' = 'just'@. +-- This behavior was changed in v3.6.0.0. If you want to produce nested 'Maybe', +-- see 'just''. +just + :: (NullableFieldProjection typ typ') + => SqlExpr (Value typ) -> SqlExpr (Value (Maybe typ')) just = veryUnsafeCoerceSqlExprValue +-- | Like 'just', but this function does not try to collapse nested 'Maybe'. +-- This may be useful if you have type inference problems with 'just'. +-- +-- @since 3.6.0.0 +just' :: SqlExpr (Value typ) -> SqlExpr (Value (Maybe typ)) +just' = veryUnsafeCoerceSqlExprValue + -- | @NULL@ value. nothing :: SqlExpr (Value (Maybe typ)) nothing = unsafeSqlValue "NULL" -- | Join nested 'Maybe's in a 'Value' into one. This is useful when -- calling aggregate functions on nullable fields. -joinV :: SqlExpr (Value (Maybe (Maybe typ))) -> SqlExpr (Value (Maybe typ)) +-- +-- As of v3.6.0.0, this function will attempt to work on both @'SqlExpr' +-- ('Value' ('Maybe' a))@ as well as @'SqlExpr' ('Value' ('Maybe' ('Maybe' a)))@ +-- inputs to make transitioning to 'NullableFieldProjection' easier. This may +-- make type inference worse in some cases. If you want the monomorphic variant, +-- see 'joinV'' +joinV + :: (NullableFieldProjection typ typ') + => SqlExpr (Value (Maybe typ)) + -> SqlExpr (Value (Maybe typ')) joinV = veryUnsafeCoerceSqlExprValue +-- | Like 'joinV', but monomorphic: the input type only works on @'SqlExpr' +-- ('Value' (Maybe (Maybe a)))@. +-- +-- This function may be useful if you have type inference issues with 'joinV'. +-- +-- @since 3.6.0.0 +joinV' + :: SqlExpr (Value (Maybe (Maybe typ))) + -> SqlExpr (Value (Maybe typ)) +joinV' = veryUnsafeCoerceSqlExprValue + countHelper :: Num a => TLB.Builder -> TLB.Builder -> SqlExpr (Value typ) -> SqlExpr (Value a) countHelper open close v = case v of @@ -886,9 +915,6 @@ between :: PersistField a => SqlExpr (Value a) -> (SqlExpr (Value a), SqlExpr (Value a)) -> SqlExpr (Value Bool) a `between` (b, c) = a >=. b &&. a <=. c -random_ :: (PersistField a, Num a) => SqlExpr (Value a) -random_ = unsafeSqlValue "RANDOM()" - round_ :: (PersistField a, Num a, PersistField b, Num b) => SqlExpr (Value a) -> SqlExpr (Value b) round_ = unsafeSqlFunction "ROUND" @@ -900,13 +926,22 @@ sum_ :: (PersistField a, PersistField b) => SqlExpr (Value a) -> SqlExpr (Value (Maybe b)) sum_ = unsafeSqlFunction "SUM" -min_ :: (PersistField a) => SqlExpr (Value a) -> SqlExpr (Value (Maybe a)) -min_ = unsafeSqlFunction "MIN" -max_ :: (PersistField a) => SqlExpr (Value a) -> SqlExpr (Value (Maybe a)) -max_ = unsafeSqlFunction "MAX" -avg_ :: (PersistField a, PersistField b) => SqlExpr (Value a) -> SqlExpr (Value (Maybe b)) -avg_ = unsafeSqlFunction "AVG" +min_ + :: (PersistField a) + => SqlExpr (Value a) + -> SqlExpr (Value (Maybe (Nullable a))) +min_ = unsafeSqlFunction "MIN" + +max_ + :: (PersistField a) + => SqlExpr (Value a) + -> SqlExpr (Value (Maybe (Nullable a))) +max_ = unsafeSqlFunction "MAX" + +avg_ :: (PersistField a, PersistField b) => SqlExpr (Value a) -> SqlExpr (Value (Maybe b)) +avg_ = unsafeSqlFunction "AVG" + -- | Allow a number of one type to be used as one of another -- type via an implicit cast. An explicit cast is not made, -- this function changes only the types on the Haskell side. @@ -940,7 +975,10 @@ -- documentation. -- -- @since 1.4.3 -coalesce :: PersistField a => [SqlExpr (Value (Maybe a))] -> SqlExpr (Value (Maybe a)) +coalesce + :: (PersistField a, NullableFieldProjection a a') + => [SqlExpr (Value (Maybe a))] + -> SqlExpr (Value (Maybe a')) coalesce = unsafeSqlFunctionParens "COALESCE" -- | Like @coalesce@, but takes a non-nullable SqlExpression @@ -996,12 +1034,15 @@ -- | @ILIKE@ operator (case-insensitive @LIKE@). -- --- Supported by PostgreSQL only. +-- Supported by PostgreSQL only. Deprecated in version 3.6.0 in favor of the +-- version available from "Database.Esqueleto.PostgreSQL". -- -- @since 2.2.3 ilike :: SqlString s => SqlExpr (Value s) -> SqlExpr (Value s) -> SqlExpr (Value Bool) ilike = unsafeSqlBinOp " ILIKE " +{-# DEPRECATED ilike "Since 3.6.0: `ilike` is only supported on Postgres. Please import it from 'Database.Esqueleto.PostgreSQL." #-} + -- | The string @'%'@. May be useful while using 'like' and -- concatenation ('concat_' or '++.', depending on your -- database). Note that you always have to type the parenthesis, @@ -1014,13 +1055,19 @@ (%) = unsafeSqlValue "'%'" -- | The @CONCAT@ function with a variable number of --- parameters. Supported by MySQL and PostgreSQL. +-- parameters. Supported by MySQL and PostgreSQL. SQLite supports this in +-- versions after 3.44.0, and @persistent-sqlite@ supports this in versions +-- @2.13.3.0@ and after. concat_ :: SqlString s => [SqlExpr (Value s)] -> SqlExpr (Value s) concat_ = unsafeSqlFunction "CONCAT" -- | The @||@ string concatenation operator (named after -- Haskell's '++' in order to avoid naming clash with '||.'). +-- -- Supported by SQLite and PostgreSQL. +-- +-- MySQL support requires setting the SQL mode to @PIPES_AS_CONCAT@ or @ANSI@ +-- - see . (++.) :: SqlString s => SqlExpr (Value s) -> SqlExpr (Value s) -> SqlExpr (Value s) (++.) = unsafeSqlBinOp " || " @@ -1167,13 +1214,13 @@ -- 'from' $ \\p -> do -- 'where_' (p '^.' PersonName '==.' 'val' \"Mike\")) -- 'then_' --- ('sub_select' $ +-- ('subSelect' $ -- 'from' $ \\v -> do -- let sub = -- 'from' $ \\c -> do -- 'where_' (c '^.' PersonName '==.' 'val' \"Mike\") -- return (c '^.' PersonFavNum) --- 'where_' (v '^.' PersonFavNum >. 'sub_select' sub) +-- 'where_' ('just' (v '^.' PersonFavNum) >. 'subSelect' sub) -- return $ 'count' (v '^.' PersonName) +. 'val' (1 :: Int)) ] -- ('else_' $ 'val' (-1)) -- @ @@ -1239,12 +1286,67 @@ toBaseId :: ToBaseId ent => SqlExpr (Value (Key ent)) -> SqlExpr (Value (Key (BaseEnt ent))) toBaseId = veryUnsafeCoerceSqlExprValue -{-# DEPRECATED random_ "Since 2.6.0: `random_` is not uniform across all databases! Please use a specific one such as 'Database.Esqueleto.PostgreSQL.random_', 'Database.Esqueleto.MySQL.random_', or 'Database.Esqueleto.SQLite.random_'" #-} +-- | Like 'toBaseId', but works on 'Maybe' keys. +-- +-- @since 3.6.0.0 +toBaseIdMaybe + :: (ToBaseId ent) + => SqlExpr (Value (Maybe (Key ent))) + -> SqlExpr (Value (Maybe (Key (BaseEnt ent)))) +toBaseIdMaybe = veryUnsafeCoerceSqlExprValue -{-# DEPRECATED rand "Since 2.6.0: `rand` ordering function is not uniform across all databases! To avoid accidental partiality it will be removed in the next major version." #-} +-- | The inverse of 'toBaseId'. Note that this is somewhat less "safe" than +-- 'toBaseId'. Calling 'toBaseId' will usually mean that a foreign key +-- constraint is present that guarantees the presence of the base ID. +-- 'fromBaseId' has no such guarantee. Consider the code example given in +-- 'toBaseId': +-- +-- @ +-- Bar +-- barNum Int +-- Foo +-- bar BarId +-- fooNum Int +-- Primary bar +-- @ +-- +-- @ +-- instance ToBaseId Foo where +-- type BaseEnt Foo = Bar +-- toBaseIdWitness barId = FooKey barId +-- @ +-- +-- The type of 'toBaseId' for @Foo@ would be: +-- +-- @ +-- toBaseId :: SqlExpr (Value FooId) -> SqlExpr (Value BarId) +-- @ +-- +-- The foreign key constraint on @Foo@ means that every @FooId@ points to +-- a @BarId@ in the database. However, 'fromBaseId' will not have this: +-- +-- @ +-- fromBaseId :: SqlExpr (Value BarId) -> SqlExpr (Value FooId) +-- @ +-- +-- @since 3.6.0.0 +fromBaseId + :: (ToBaseId ent) + => SqlExpr (Value (Key (BaseEnt ent))) + -> SqlExpr (Value (Key ent)) +fromBaseId = veryUnsafeCoerceSqlExprValue +-- | As 'fromBaseId', but works on 'Maybe' keys. +-- +-- @since 3.6.0.0 +fromBaseIdMaybe + :: (ToBaseId ent) + => SqlExpr (Value (Maybe (Key (BaseEnt ent)))) + -> SqlExpr (Value (Maybe (Key ent))) +fromBaseIdMaybe = veryUnsafeCoerceSqlExprValue + -- Fixity declarations -infixl 9 ^. +infixl 9 ^., ?. infixl 7 *., /. infixl 6 +., -. infixr 5 ++. @@ -1591,6 +1693,32 @@ -- -- @since 2.2.7 +{-# DEPRECATED ForUpdate, ForUpdateSkipLocked "The constructors for 'LockingKind' are deprecated in v3.6.0.0. Instead, please refer to the smart constructors 'forUpdate' and 'forUpdateSkipLocked'." #-} +{-# DEPRECATED ForShare "The constructors for 'LockingKind' are deprecated in v3.6.0.0. Instead, please refer to the smart constructor 'forShare' exported from Database.Esqueleto.PostgreSQL." #-} +{-# DEPRECATED LockInShareMode "The constructors for 'LockingKind' are deprecated in v3.6.0.0. Instead, please refer to the smart constructors 'lockInShareMode' exported from Database.Esqueleto.MySQL." #-} + +-- | @FOR UPDATE@ syntax. +-- +-- Usage: +-- +-- @ +-- 'locking' 'forUpdate' +-- @ +-- +-- @since 3.6.0.0 +forUpdate :: LockingKind +forUpdate = ForUpdate + +-- | @FOR UPDATE SKIP LOCKED@ syntax. +-- +-- @ +-- 'locking' 'forUpdateSkipLocked' +-- @ +-- +-- @since 3.6.0.0 +forUpdateSkipLocked :: LockingKind +forUpdateSkipLocked = ForUpdateSkipLocked + -- | Postgres specific locking, used only internally -- -- @since 3.5.9.0 @@ -2340,12 +2468,12 @@ entityAsValue :: SqlExpr (Entity val) -> SqlExpr (Value (Entity val)) -entityAsValue = coerce +entityAsValue = veryUnsafeCoerceSqlExpr entityAsValueMaybe :: SqlExpr (Maybe (Entity val)) -> SqlExpr (Value (Maybe (Entity val))) -entityAsValueMaybe = coerce +entityAsValueMaybe = veryUnsafeCoerceSqlExpr -- | An expression on the SQL backend. -- @@ -2357,6 +2485,51 @@ -- interpolated by the SQL backend. data SqlExpr a = ERaw SqlExprMeta (NeedParens -> IdentInfo -> (TLB.Builder, [PersistValue])) +type role SqlExpr nominal + +-- | The type @'SqlExpr' a@ represents a SQL expression that evaluates to +-- a value that can be parsed in Haskell to an @a@. There are often many +-- underlying SQL values that can parse exactly. The function +-- 'veryUnsafeCoerceSqlExpr' allows you to change this type. +-- +-- There is no guarantee that the result works! To be safe, you want to provide +-- a local helper function that calls this at a tested type. +-- +-- As an example, you may know that two types share an identical SQL +-- representation, and can be parsed exactly the same way. Perhaps you have +-- a @data SomeEnum@ which you represent as a @TEXT@ in Postgres, and you +-- want to treat it as a @TEXT@. You could define a top-level +-- type-restricted alias to this which allows this to be done safely: +-- +-- @ +-- enumToText :: SqlExpr (Value SomeEnum) -> SqlExpr (Value Text) +-- enumToText = veryUnsafeCoerceSqlExpr +-- @ +-- +-- Note that this is fragile: if you change the encoding of 'SomeEnum' to +-- be anything other than 'Text', then your code will fail at runtime. +-- +-- @since 3.6.0.0 +veryUnsafeCoerceSqlExpr :: SqlExpr a -> SqlExpr b +veryUnsafeCoerceSqlExpr (ERaw m k) = ERaw m k + +-- | While 'veryUnsafeCoerceSqlExpr' allows you to coerce anything at all, this +-- requires that the two types are 'Coercible' in Haskell. This is not truly +-- safe: after all, the point of @newtype@ is to allow you to provide different +-- instances of classes like 'PersistFieldSql' and 'SqlSelect'. Using this may +-- break your code if you change the underlying SQL representation. +-- +-- @since 3.6.0.0 +unsafeCoerceSqlExpr :: (Coercible a b) => SqlExpr a -> SqlExpr b +unsafeCoerceSqlExpr = veryUnsafeCoerceSqlExpr + +-- | Like 'unsafeCoerceSqlExpr' but for the common case where you are +-- coercing a 'Value'. +-- +-- @since 3.6.0.0 +unsafeCoerceSqlExprValue :: (Coercible a b) => SqlExpr (Value a) -> SqlExpr (Value b) +unsafeCoerceSqlExprValue = veryUnsafeCoerceSqlExpr + -- | Folks often want the ability to promote a Haskell function into the -- 'SqlExpr' expression language - and naturally reach for 'fmap'. -- Unfortunately, this is impossible. We cannot send *functions* to the @@ -2472,12 +2645,44 @@ -- -- @since 3.5.4.0 instance - (PersistEntity rec, PersistField typ, SymbolToField sym rec typ) + (PersistEntity rec, PersistField typ, PersistField typ', SymbolToField sym rec typ + , NullableFieldProjection typ typ' + , HasField sym (SqlExpr (Maybe (Entity rec))) (SqlExpr (Value (Maybe typ'))) + ) => - HasField sym (SqlExpr (Maybe (Entity rec))) (SqlExpr (Value (Maybe typ))) + HasField sym (SqlExpr (Maybe (Entity rec))) (SqlExpr (Value (Maybe typ'))) where - getField expr = expr ?. symbolToField @sym + getField expr = veryUnsafeCoerceSqlExpr (expr ?. symbolToField @sym) +-- | The 'NullableFieldProjection' type is used to determine whether +-- a 'Maybe' should be stripped off or not. This is used in the 'HasField' +-- for @'SqlExpr' ('Maybe' ('Entity' a))@ to allow you to only have +-- a single level of 'Maybe'. +-- +-- @ +-- MyTable +-- column Int Maybe +-- someTableId SomeTableId +-- +-- select $ do +-- (_ :& maybeMyTable) <- +-- from $ table @SomeTable +-- `leftJoin` table @MyTable +-- `on` do +-- \(someTable :& maybeMyTable) -> +-- just someTable.id ==. maybeMyTable.someTableId +-- where_ $ maybeMyTable.column ==. just (val 10) +-- pure maybeMyTable +-- @ +-- +-- Without this class, projecting a field with type @'Maybe' typ@ would +-- have resulted in a @'SqlExpr' ('Value' ('Maybe' ('Maybe' typ)))@. +-- +-- @since 3.6.0.0 +class NullableFieldProjection typ typ' +instance {-# incoherent #-} (typ ~ typ') => NullableFieldProjection (Maybe typ) typ' +instance {-# overlappable #-} (typ ~ typ') => NullableFieldProjection typ typ' + -- | Data type to support from hack data PreprocessedFrom a = PreprocessedFrom a FromClause @@ -2826,14 +3031,20 @@ -- | (Internal) Coerce a value's type from 'SqlExpr (Value a)' to -- 'SqlExpr (Value b)'. You should /not/ use this function -- unless you know what you're doing! +-- +-- This is an alias for 'veryUnsafeCoerceSqlExpr' with the type fixed to +-- 'Value'. veryUnsafeCoerceSqlExprValue :: SqlExpr (Value a) -> SqlExpr (Value b) -veryUnsafeCoerceSqlExprValue = coerce +veryUnsafeCoerceSqlExprValue = veryUnsafeCoerceSqlExpr -- | (Internal) Coerce a value's type from 'SqlExpr (ValueList -- a)' to 'SqlExpr (Value a)'. Does not work with empty lists. +-- +-- This is an alias for 'veryUnsafeCoerceSqlExpr', with the type fixed to +-- 'ValueList' and 'Value'. veryUnsafeCoerceSqlExprValueList :: SqlExpr (ValueList a) -> SqlExpr (Value a) -veryUnsafeCoerceSqlExprValueList = coerce +veryUnsafeCoerceSqlExprValueList = veryUnsafeCoerceSqlExpr ---------------------------------------------------------------------- @@ -3257,7 +3468,7 @@ first (("SELECT DISTINCT ON (" <>) . (<> ") ")) $ uncommas' (processExpr <$> exprs) where - processExpr e = materializeExpr info (coerce e :: SqlExpr (Value a)) + processExpr e = materializeExpr info (veryUnsafeCoerceSqlExpr e :: SqlExpr (Value a)) withCols v = v <> sqlSelectCols info ret plain v = (v, []) @@ -3513,7 +3724,7 @@ -- | You may return a possibly-@NULL@ 'Entity' from a 'select' query. instance PersistEntity a => SqlSelect (SqlExpr (Maybe (Entity a))) (Maybe (Entity a)) where - sqlSelectCols info e = sqlSelectCols info (coerce e :: SqlExpr (Entity a)) + sqlSelectCols info e = sqlSelectCols info (veryUnsafeCoerceSqlExpr e :: SqlExpr (Entity a)) sqlSelectColCount = sqlSelectColCount . fromEMaybe where fromEMaybe :: Proxy (SqlExpr (Maybe e)) -> Proxy (SqlExpr e) @@ -4251,3 +4462,7 @@ (\(oneOld, manyOld) (_, manyNew) -> (oneOld, manyNew ++ manyOld )) (entityKey one) (entityVal one, [many]) + +type family Nullable a where + Nullable (Maybe a) = a + Nullable a = a diff --git a/src/Database/Esqueleto/Legacy.hs b/src/Database/Esqueleto/Legacy.hs --- a/src/Database/Esqueleto/Legacy.hs +++ b/src/Database/Esqueleto/Legacy.hs @@ -52,14 +52,14 @@ -- $gettingstarted -- * @esqueleto@'s Language - where_, on, groupBy, orderBy, rand, asc, desc, limit, offset + where_, on, groupBy, orderBy, asc, desc, limit, offset , distinct, distinctOn, don, distinctOnOrderBy, having, locking - , sub_select, (^.), (?.) - , val, isNothing, just, nothing, joinV, withNonNull + , (^.), (?.) + , val, isNothing, just, just', nothing, joinV, joinV', withNonNull , countRows, count, countDistinct , not_, (==.), (>=.), (>.), (<=.), (<.), (!=.), (&&.), (||.) , between, (+.), (-.), (/.), (*.) - , random_, round_, ceiling_, floor_ + , round_, ceiling_, floor_ , min_, max_, sum_, avg_, castNum, castNumM , coalesce, coalesceDefault , lower_, upper_, trim_, ltrim_, rtrim_, length_, left_, right_ @@ -67,7 +67,7 @@ , subList_select, valList, justList , in_, notIn, exists, notExists , set, (=.), (+=.), (-=.), (*=.), (/=.) - , case_, toBaseId + , case_, toBaseId, fromBaseId, fromBaseIdMaybe, toBaseIdMaybe , subSelect , subSelectMaybe , subSelectCount @@ -84,6 +84,8 @@ , OrderBy , DistinctOn , LockingKind(..) + , forUpdate + , forUpdateSkipLocked , LockableEntity(..) , SqlString -- ** Joins diff --git a/src/Database/Esqueleto/MySQL.hs b/src/Database/Esqueleto/MySQL.hs --- a/src/Database/Esqueleto/MySQL.hs +++ b/src/Database/Esqueleto/MySQL.hs @@ -5,6 +5,7 @@ -- @since 2.2.8 module Database.Esqueleto.MySQL ( random_ + , lockInShareMode ) where import Database.Esqueleto.Internal.Internal hiding (random_) @@ -13,6 +14,18 @@ -- | (@random()@) Split out into database specific modules -- because MySQL uses `rand()`. -- --- /Since: 2.6.0/ +-- @since 2.6.0 random_ :: (PersistField a, Num a) => SqlExpr (Value a) random_ = unsafeSqlValue "RAND()" + +-- | @LOCK IN SHARE MODE@ syntax. +-- +-- Example: +-- +-- @ +-- 'locking' 'lockInShareMode' +-- @ +-- +-- @since 3.6.0.0 +lockInShareMode :: LockingKind +lockInShareMode = LockInShareMode diff --git a/src/Database/Esqueleto/PostgreSQL.hs b/src/Database/Esqueleto/PostgreSQL.hs --- a/src/Database/Esqueleto/PostgreSQL.hs +++ b/src/Database/Esqueleto/PostgreSQL.hs @@ -9,7 +9,7 @@ -- | This module contain PostgreSQL-specific functions. -- --- @since: 2.2.8 +-- @since 2.2.8 module Database.Esqueleto.PostgreSQL ( AggMode(..) , arrayAggDistinct @@ -24,7 +24,9 @@ , now_ , random_ , upsert + , upsertMaybe , upsertBy + , upsertMaybeBy , insertSelectWithConflict , insertSelectWithConflictCount , noWait @@ -32,10 +34,14 @@ , skipLocked , forUpdateOf , forNoKeyUpdateOf + , forShare , forShareOf , forKeyShareOf , filterWhere , values + , ilike + , distinctOn + , distinctOnOrderBy , withMaterialized , withNotMaterialized , ascNullsFirst @@ -46,9 +52,6 @@ , unsafeSqlAggregateFunction ) where -#if __GLASGOW_HASKELL__ < 804 -import Data.Semigroup -#endif import Control.Arrow (first) import Control.Exception (throw) import Control.Monad (void) @@ -59,6 +62,7 @@ import qualified Data.List.NonEmpty as NE import Data.Maybe import Data.Proxy (Proxy(..)) +import qualified Data.Text as Text import qualified Data.Text.Internal.Builder as TLB import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TLB @@ -69,10 +73,14 @@ import Database.Esqueleto.Experimental.From.SqlSetOperation import Database.Esqueleto.Experimental.ToAlias import Database.Esqueleto.Experimental.ToAliasReference -import Database.Esqueleto.Internal.Internal hiding (From(..), from, on, random_) +import Database.Esqueleto.Internal.Internal hiding + (From(..), ilike, distinctOn, distinctOnOrderBy, from, on, random_) import Database.Esqueleto.Internal.PersistentImport hiding (uniqueFields, upsert, upsertBy) +import Database.Persist (ConstraintNameDB(..), EntityNameDB(..)) +import Database.Persist.Class (OnlyOneUniqueKey) import Database.Persist.SqlBackend +import GHC.Stack -- | (@random()@) Split out into database specific modules -- because MySQL uses `rand()`. @@ -81,6 +89,69 @@ random_ :: (PersistField a, Num a) => SqlExpr (Value a) random_ = unsafeSqlValue "RANDOM()" +-- | @DISTINCT ON@. Change the current @SELECT@ into +-- @SELECT DISTINCT ON (SqlExpressions)@. For example: +-- +-- @ +-- select $ do +-- foo <- 'from' $ table \@Foo +-- 'distinctOn' ['don' (foo ^. FooName), 'don' (foo ^. FooState)] +-- pure foo +-- @ +-- +-- You can also chain different calls to 'distinctOn'. The +-- above is equivalent to: +-- +-- @ +-- select $ do +-- foo <- 'from' $ table \@Foo +-- 'distinctOn' ['don' (foo ^. FooName)] +-- 'distinctOn' ['don' (foo ^. FooState)] +-- pure foo +-- @ +-- +-- Each call to 'distinctOn' adds more SqlExpressions. Calls to +-- 'distinctOn' override any calls to 'distinct'. +-- +-- Note that PostgreSQL requires the SqlExpressions on @DISTINCT +-- ON@ to be the first ones to appear on a @ORDER BY@. This is +-- not managed automatically by esqueleto, keeping its spirit +-- of trying to be close to raw SQL. +-- +-- @since 3.6.0 +distinctOn :: [SqlExpr DistinctOn] -> SqlQuery () +distinctOn exprs = Q (W.tell mempty { sdDistinctClause = DistinctOn exprs }) + +-- | A convenience function that calls both 'distinctOn' and +-- 'orderBy'. In other words, +-- +-- @ +-- 'distinctOnOrderBy' [asc foo, desc bar, desc quux] +-- @ +-- +-- is the same as: +-- +-- @ +-- 'distinctOn' [don foo, don bar, don quux] +-- 'orderBy' [asc foo, desc bar, desc quux] +-- ... +-- @ +-- +-- @since 3.6.0.0 +distinctOnOrderBy :: [SqlExpr OrderBy] -> SqlQuery () +distinctOnOrderBy exprs = do + distinctOn (toDistinctOn <$> exprs) + orderBy exprs + where + toDistinctOn :: SqlExpr OrderBy -> SqlExpr DistinctOn + toDistinctOn (ERaw m f) = ERaw m $ \p info -> + let (b, vals) = f p info + in ( TLB.fromLazyText + $ TL.replace " DESC" "" + $ TL.replace " ASC" "" + $ TLB.toLazyText b + , vals ) + -- | Empty array literal. (@val []@) does unfortunately not work emptyArray :: SqlExpr (Value [a]) emptyArray = unsafeSqlValue "'{}'" @@ -198,6 +269,15 @@ now_ :: SqlExpr (Value UTCTime) now_ = unsafeSqlFunction "NOW" () +-- | Perform an @upsert@ operation on the given record. +-- +-- If the record exists in the database already, then the updates will be +-- performed on that record. If the record does not exist, then the +-- provided record will be inserted. +-- +-- If you wish to provide an empty list of updates (ie "if the record +-- exists, do nothing"), then you will need to call 'upsertMaybe'. Postgres +-- will not return anything if there are no modifications or inserts made. upsert :: ( MonadIO m @@ -208,29 +288,69 @@ ) => record -- ^ new record to insert - -> [SqlExpr (Entity record) -> SqlExpr Update] + -> NE.NonEmpty (SqlExpr (Entity record) -> SqlExpr Update) -- ^ updates to perform if the record already exists -> R.ReaderT SqlBackend m (Entity record) -- ^ the record in the database after the operation -upsert record updates = do - uniqueKey <- onlyUnique record - upsertBy uniqueKey record updates +upsert record = + upsertBy (onlyUniqueP record) record -upsertBy +-- | Like 'upsert', but permits an empty list of updates to be performed. +-- +-- If no updates are provided and the record already was present in the +-- database, then this will return 'Nothing'. If you want to fetch the +-- record out of the database, you can write: +-- +-- @ +-- mresult <- upsertMaybe record [] +-- case mresult of +-- Nothing -> +-- 'getBy' ('onlyUniqueP' record) +-- Just res -> +-- pure (Just res) +-- @ +-- +-- @since 3.6.0.0 +upsertMaybe :: - (MonadIO m + ( MonadIO m , PersistEntity record + , OnlyOneUniqueKey record + , PersistRecordBackend record SqlBackend , IsPersistBackend (PersistEntityBackend record) ) + => record + -- ^ new record to insert + -> [SqlExpr (Entity record) -> SqlExpr Update] + -- ^ updates to perform if the record already exists + -> R.ReaderT SqlBackend m (Maybe (Entity record)) + -- ^ the record in the database after the operation +upsertMaybe rec upds = do + upsertMaybeBy (onlyUniqueP rec) rec upds + +-- | Attempt to insert a @record@ into the database. If the @record@ +-- already exists for the given @'Unique' record@, then a list of updates +-- will be performed. +-- +-- If you provide an empty list of updates, then this function will return +-- 'Nothing' if the record already exists in the database. +-- +-- @since 3.6.0.0 +upsertMaybeBy + :: + ( MonadIO m + , PersistEntity record + , IsPersistBackend (PersistEntityBackend record) + ) => Unique record -- ^ uniqueness constraint to find by -> record -- ^ new record to insert -> [SqlExpr (Entity record) -> SqlExpr Update] -- ^ updates to perform if the record already exists - -> R.ReaderT SqlBackend m (Entity record) + -> R.ReaderT SqlBackend m (Maybe (Entity record)) -- ^ the record in the database after the operation -upsertBy uniqueKey record updates = do +upsertMaybeBy uniqueKey record updates = do sqlB <- R.ask case getConnUpsertSql sqlB of Nothing -> @@ -240,36 +360,70 @@ Just upsertSql -> handler sqlB upsertSql where - addVals l = map toPersistValue (toPersistFields record) ++ l ++ persistUniqueToValues uniqueKey - entDef = entityDef (Just record) - updatesText conn = first builderToText $ renderUpdates conn updates -#if MIN_VERSION_persistent(2,11,0) + addVals l = + map toPersistValue (toPersistFields record) ++ l ++ case updates of + [] -> + [] + _ -> + persistUniqueToValues uniqueKey + entDef = + entityDef (Just record) + updatesText conn = + first builderToText $ renderUpdates conn updates uniqueFields = persistUniqueToFieldNames uniqueKey handler sqlB upsertSql = do let (updateText, updateVals) = updatesText sqlB - queryText = + queryTextUnmodified = upsertSql entDef uniqueFields updateText + queryText = + case updates of + [] -> + let + (okay, _bad) = + Text.breakOn "DO UPDATE" queryTextUnmodified + good = + okay <> "DO NOTHING RETURNING ??" + in + good + _ -> + queryTextUnmodified + queryVals = addVals updateVals xs <- rawSql queryText queryVals - pure (head xs) -#else - uDef = toUniqueDef uniqueKey - handler conn f = fmap head $ uncurry rawSql $ - (***) (f entDef (uDef :| [])) addVals $ updatesText conn -#endif + pure (listToMaybe xs) +upsertBy + :: + ( MonadIO m + , PersistEntity record + , IsPersistBackend (PersistEntityBackend record) + , HasCallStack + ) + => Unique record + -- ^ uniqueness constraint to find by + -> record + -- ^ new record to insert + -> NE.NonEmpty (SqlExpr (Entity record) -> SqlExpr Update) + -- ^ updates to perform if the record already exists + -> R.ReaderT SqlBackend m (Entity record) + -- ^ the record in the database after the operation +upsertBy uniqueKey record updates = do + mrec <- upsertMaybeBy uniqueKey record (NE.toList updates) + case mrec of + Nothing -> + error "non-empty list of updates should have resulted in a row being returned" + Just rec -> + pure rec + -- | Inserts into a table the results of a query similar to 'insertSelect' but allows -- to update values that violate a constraint during insertions. -- -- Example of usage: -- -- @ --- share [ mkPersist sqlSettings --- , mkDeleteCascade sqlSettings --- , mkMigrate "migrate" --- ] [persistLowerCase| +-- 'mkPersist' 'sqlSettings' ['persistLowerCase'| -- Bar -- num Int -- deriving Eq Show @@ -279,17 +433,19 @@ -- deriving Eq Show -- |] -- --- insertSelectWithConflict --- UniqueFoo -- (UniqueFoo undefined) or (UniqueFoo anyNumber) would also work --- (from $ \b -> --- return $ Foo <# (b ^. BarNum) --- ) --- (\current excluded -> --- [FooNum =. (current ^. FooNum) +. (excluded ^. FooNum)] --- ) +-- action = do +-- 'insertSelectWithConflict' +-- UniqueFoo -- (UniqueFoo undefined) or (UniqueFoo anyNumber) would also work +-- (do +-- b <- from $ table \@Bar +-- return $ Foo <# (b ^. BarNum) +-- ) +-- (\\current excluded -> +-- [FooNum =. (current ^. FooNum) +. (excluded ^. FooNum)] +-- ) -- @ -- --- Inserts to table Foo all Bar.num values and in case of conflict SomeFooUnique, +-- Inserts to table @Foo@ all @Bar.num@ values and in case of conflict @SomeFooUnique@, -- the conflicting value is updated to the current plus the excluded. -- -- @since 3.1.3 @@ -500,6 +656,18 @@ forShareOf lockableEntities onLockedBehavior = putLocking $ PostgresLockingClauses [PostgresLockingKind PostgresForShare (Just $ LockingOfClause lockableEntities) onLockedBehavior] +-- | @FOR SHARE@ syntax for Postgres locking. +-- +-- Example use: +-- +-- @ +-- 'locking' 'forShare' +-- @ +-- +-- @since 3.6.0.0 +forShare :: LockingKind +forShare = ForShare + -- | `FOR KEY SHARE OF` syntax for postgres locking -- allows locking of specific tables with a key share lock in a view or join -- @@ -507,6 +675,13 @@ forKeyShareOf :: LockableEntity a => a -> OnLockedBehavior -> SqlQuery () forKeyShareOf lockableEntities onLockedBehavior = putLocking $ PostgresLockingClauses [PostgresLockingKind PostgresForKeyShare (Just $ LockingOfClause lockableEntities) onLockedBehavior] + +-- | @ILIKE@ operator (case-insensitive @LIKE@). +-- +-- @since 2.2.3 +ilike :: SqlString s => SqlExpr (Value s) -> SqlExpr (Value s) -> SqlExpr (Value Bool) +ilike = unsafeSqlBinOp " ILIKE " +infixr 2 `ilike` -- | @WITH@ @MATERIALIZED@ clause is used to introduce a -- [Common Table Expression (CTE)](https://en.wikipedia.org/wiki/Hierarchical_and_recursive_queries_in_SQL#Common_table_expression) diff --git a/test/Common/Test.hs b/test/Common/Test.hs --- a/test/Common/Test.hs +++ b/test/Common/Test.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} @@ -32,7 +33,6 @@ ( tests , testLocking , testAscRandom - , testRandomMath , migrateAll , migrateUnique , cleanDB @@ -65,6 +65,7 @@ , DateTruncTest(..) , DateTruncTestId , Key(..) + , assertJust ) where import Common.Test.Import hiding (from, on) @@ -160,19 +161,8 @@ pure (n ^. NumbersInt) setup res <- select $ pure $ subSelect query - eres <- try $ do - select $ pure $ sub_select query asserting $ do res `shouldBe` [Value (Just 1)] - case eres of - Left (SomeException _) -> - -- We should receive an exception, but the different database - -- libraries throw different exceptions. Hooray. - pure () - Right v -> - -- This shouldn't happen, but in sqlite land, many things are - -- possible. - v `shouldBe` [Value 1] itDb "is safe for queries that may not return anything" $ do let query = @@ -184,21 +174,8 @@ res <- select $ pure $ subSelect query transactionUndo - eres <- try $ do - select $ pure $ sub_select query - asserting $ do res `shouldBe` [Value $ Just 1] - case eres of - Left (_ :: PersistException) -> - -- We expect to receive this exception. However, sqlite evidently has - -- no problems with itDb, so we can't *require* that the exception is - -- thrown. Sigh. - pure () - Right v -> - -- This shouldn't happen, but in sqlite land, many things are - -- possible. - v `shouldBe` [Value 1] describe "subSelectList" $ do itDb "is safe on empty databases as well as good databases" $ do @@ -405,7 +382,7 @@ , (p2e, p2e) ] - itDb "works for a self-join via sub_select" $ do + itDb "works for a self-join via subSelect" $ do p1k <- insert p1 p2k <- insert p2 _f1k <- insert (Follow p1k p2k) @@ -416,7 +393,7 @@ from $ \followB -> do where_ $ followA ^. FollowFollower ==. followB ^. FollowFollowed return $ followB ^. FollowFollower - where_ $ followA ^. FollowFollowed ==. sub_select subquery + where_ $ just (followA ^. FollowFollowed) ==. subSelect subquery return followA asserting $ length ret `shouldBe` 2 @@ -744,7 +721,7 @@ _ <- insert' p3 let q = do (name, age) <- - Experimental.from $ SubQuery $ do + Experimental.from $ do p <- Experimental.from $ Table @Person return ( p ^. PersonName, p ^. PersonAge) orderBy [ asc age ] @@ -765,7 +742,7 @@ lord ^. LordId ==. deed ^. DeedOwnerId) return (lord ^. LordId, deed ^. DeedId) q' = do - (lordId, deedId) <- Experimental.from $ SubQuery q + (lordId, deedId) <- Experimental.from q groupBy (lordId) return (lordId, count deedId) (ret :: [(Value (Key Lord), Value Int)]) <- select q' @@ -788,7 +765,7 @@ return (lord ^. LordId, count (deed ^. DeedId)) (ret :: [(Value Int)]) <- select $ do - (lordId, deedCount) <- Experimental.from $ SubQuery q + (lordId, deedCount) <- Experimental.from q where_ $ deedCount >. val (3 :: Int) return (count lordId) @@ -1135,12 +1112,12 @@ return p asserting $ ret `shouldBe` [ p1e, p3e, p2e ] - itDb "works with a sub_select" $ do + itDb "works with a subSelect" $ do [p1k, p2k, p3k, p4k] <- mapM insert [p1, p2, p3, p4] [b1k, b2k, b3k, b4k] <- mapM (insert . BlogPost "") [p1k, p2k, p3k, p4k] ret <- select $ from $ \b -> do - orderBy [desc $ sub_select $ + orderBy [desc $ subSelect $ from $ \p -> do where_ (p ^. PersonId ==. b ^. BlogPostAuthorId) return (p ^. PersonName) @@ -1244,8 +1221,8 @@ let sub = from $ \p -> do where_ (p ^. PersonId ==. b ^. BlogPostAuthorId) - return $ p ^. PersonAge - return $ coalesceDefault [sub_select sub] (val (42 :: Int)) + pure $ p ^. PersonAge + return $ coalesceDefault [joinV $ subSelect sub] (val (42 :: Int)) asserting $ ret `shouldBe` [ Value (36 :: Int) , Value 42 , Value 17 @@ -1288,7 +1265,7 @@ where_ (b ^. BlogPostAuthorId ==. p ^. PersonId) return countRows () <- update $ \p -> do - set p [ PersonAge =. just (sub_select (blogPostsBy p)) ] + set p [ PersonAge =. subSelect (blogPostsBy p) ] ret <- select $ from $ \p -> do orderBy [ asc (p ^. PersonName) ] @@ -1557,31 +1534,6 @@ asserting $ ret `shouldBe` [Value (3::Int)] asserting $ cnt `shouldBe` 3 - - - -testRandomMath :: SpecDb -testRandomMath = describe "random_ math" $ - itDb "rand returns result in random order" $ - do - replicateM_ 20 $ do - _ <- insert p1 - _ <- insert p2 - _ <- insert p3 - _ <- insert p4 - _ <- insert $ Person "Jane" Nothing Nothing 0 - _ <- insert $ Person "Mark" Nothing Nothing 0 - _ <- insert $ Person "Sarah" Nothing Nothing 0 - insert $ Person "Paul" Nothing Nothing 0 - ret1 <- fmap (map unValue) $ select $ from $ \p -> do - orderBy [rand] - return (p ^. PersonId) - ret2 <- fmap (map unValue) $ select $ from $ \p -> do - orderBy [rand] - return (p ^. PersonId) - - asserting $ (ret1 == ret2) `shouldBe` False - testMathFunctions :: SpecDb testMathFunctions = do describe "Math-related functions" $ do @@ -1639,16 +1591,16 @@ (exists $ from $ \p -> do where_ (p ^. PersonName ==. val "Mike")) then_ - (sub_select $ from $ \v -> do + (subSelect $ from $ \v -> do let sub = from $ \c -> do where_ (c ^. PersonName ==. val "Mike") return (c ^. PersonFavNum) - where_ (v ^. PersonFavNum >. sub_select sub) + where_ (just (v ^. PersonFavNum) >. subSelect sub) return $ count (v ^. PersonName) +. val (1 :: Int)) ] - (else_ $ val (-1)) + (else_ $ just $ val (-1)) - asserting $ ret `shouldBe` [ Value (3) ] + asserting $ ret `shouldBe` [ Value (Just 3) ] testLocking :: SpecDb testLocking = do @@ -2370,7 +2322,7 @@ insert_ p3 -- Pretend this isnt all posts upperNames <- select $ do - author <- Experimental.from $ SelectQuery $ Experimental.from $ Table @Person + author <- Experimental.from $ Experimental.from $ Table @Person pure $ upper_ $ author ^. PersonName asserting $ upperNames `shouldMatchList` [ Value "JOHN" @@ -2536,7 +2488,7 @@ pure bp.title describe "with SqlExpr (Maybe (Entity rec))" $ do itDb "lets you project from a Maybe record" $ do - select $ do + void $ select $ do p :& mbp <- Experimental.from $ table @Person `leftJoin` table @BlogPost @@ -2545,6 +2497,34 @@ just p.id ==. mbp.authorId pure (p.id, mbp.title) + itDb "joins Maybe together" $ do + void $ select $ do + deed :& lord <- + Experimental.from $ + table @Deed + `leftJoin` table @Lord + `Experimental.on` do + \(deed :& lord) -> + lord.id ==. just deed.ownerId + where_ $ lord.dogs >=. just (val 10) + where_ $ joinV lord.dogs >=. just (just (val 10)) + where_ $ lord.dogs >=. just (val (Just 10)) + + itDb "i didn't bork ?." $ do + weights <- select $ do + (pro :& per) <- Experimental.from $ + table @Profile + `leftJoin` table @Person + `Experimental.on` do + \(pro :& per) -> + just (pro ^. #person) ==. per ?. #id + &&. just pro.person ==. per ?. PersonId + pure $ per ?. #weight + asserting $ do + weights `shouldBe` ([] :: [Value (Maybe Int)]) + + + #else it "is only supported in GHC 9.2 or above" $ \_ -> do pending @@ -2573,3 +2553,5 @@ pure (person, blogPost, profile, reply) asserting noExceptions +assertJust :: HasCallStack => Maybe a -> IO a +assertJust = maybe (expectationFailure "Expected Just, got Nothing" >> error "asdf") pure diff --git a/test/Common/Test/Models.hs b/test/Common/Test/Models.hs --- a/test/Common/Test/Models.hs +++ b/test/Common/Test/Models.hs @@ -207,4 +207,3 @@ instance ToBaseId ArticleMetadata where type BaseEnt ArticleMetadata = Article toBaseIdWitness articleId = ArticleMetadataKey articleId - diff --git a/test/PostgreSQL/Test.hs b/test/PostgreSQL/Test.hs --- a/test/PostgreSQL/Test.hs +++ b/test/PostgreSQL/Test.hs @@ -57,6 +57,37 @@ import Common.Test.Import hiding (from, on) import PostgreSQL.MigrateJSON +spec :: Spec +spec = beforeAll mkConnectionPool $ do + tests + + describe "PostgreSQL specific tests" $ do + testAscRandom random_ + testSelectDistinctOn + testPostgresModule + testPostgresqlOneAscOneDesc + testPostgresqlTwoAscFields + testPostgresqlSum + testPostgresqlRandom + testPostgresqlUpdate + testPostgresqlCoalesce + testPostgresqlTextFunctions + testInsertUniqueViolation + testUpsert + testInsertSelectWithConflict + testFilterWhere + testCommonTableExpressions + setDatabaseState insertJsonValues cleanJSON + $ describe "PostgreSQL JSON tests" $ do + testJSONInsertions + testJSONOperators + testLateralQuery + testValuesExpression + testSubselectAliasingBehavior + testPostgresqlLocking + testPostgresqlNullsOrdering + + returningType :: forall a m . m a -> m a returningType a = a @@ -1044,18 +1075,29 @@ sqlErrorHint = ""} testUpsert :: SpecDb -testUpsert = - describe "Upsert test" $ do +testUpsert = describe "Upsert test" $ do itDb "Upsert can insert like normal" $ do - u1e <- EP.upsert u1 [OneUniqueName =. val "fifth"] - liftIO $ entityVal u1e `shouldBe` u1 + u1e <- EP.upsert u1 (pure (OneUniqueName =. val "fifth")) + liftIO $ entityVal u1e `shouldBe` u1 itDb "Upsert performs update on collision" $ do - u1e <- EP.upsert u1 [OneUniqueName =. val "fifth"] - liftIO $ entityVal u1e `shouldBe` u1 - u2e <- EP.upsert u2 [OneUniqueName =. val "fifth"] - liftIO $ entityVal u2e `shouldBe` u2 - u3e <- EP.upsert u3 [OneUniqueName =. val "fifth"] - liftIO $ entityVal u3e `shouldBe` u1{oneUniqueName="fifth"} + u1e <- EP.upsert u1 (pure (OneUniqueName =. val "fifth")) + liftIO $ entityVal u1e `shouldBe` u1 + u2e <- EP.upsert u2 (pure (OneUniqueName =. val "fifth")) + liftIO $ entityVal u2e `shouldBe` u2 + u3e <- EP.upsert u3 (pure (OneUniqueName =. val "fifth")) + liftIO $ entityVal u3e `shouldBe` u1{oneUniqueName="fifth"} + describe "With no updates" $ do + itDb "Works with no updates" $ do + _ <- EP.upsertMaybe u1 [] + pure () + itDb "Works with no updates, twice" $ do + mu1 <- EP.upsertMaybe u1 [] + Entity u1Key u1' <- liftIO $ assertJust mu1 + mu2 <- EP.upsertMaybe u1 { oneUniqueName = "Something Else" } [] + asserting $ do + mu2 `shouldBe` Nothing + -- liftIO $ do + -- u1 `shouldBe` u1' testInsertSelectWithConflict :: SpecDb testInsertSelectWithConflict = @@ -1729,43 +1771,6 @@ selectJSON f = select $ from $ \v -> do f $ just (v ^. JsonValue) return v - ---------------- JSON --------------- JSON --------------- JSON --------------- ---------------- JSON --------------- JSON --------------- JSON --------------- ---------------- JSON --------------- JSON --------------- JSON --------------- - - - -spec :: Spec -spec = beforeAll mkConnectionPool $ do - tests - - describe "PostgreSQL specific tests" $ do - testAscRandom random_ - testRandomMath - testSelectDistinctOn - testPostgresModule - testPostgresqlOneAscOneDesc - testPostgresqlTwoAscFields - testPostgresqlSum - testPostgresqlRandom - testPostgresqlUpdate - testPostgresqlCoalesce - testPostgresqlTextFunctions - testInsertUniqueViolation - testUpsert - testInsertSelectWithConflict - testFilterWhere - testCommonTableExpressions - setDatabaseState insertJsonValues cleanJSON - $ describe "PostgreSQL JSON tests" $ do - testJSONInsertions - testJSONOperators - testLateralQuery - testValuesExpression - testSubselectAliasingBehavior - testPostgresqlLocking - testPostgresqlNullsOrdering insertJsonValues :: SqlPersistT IO () insertJsonValues = do diff --git a/test/SQLite/Test.hs b/test/SQLite/Test.hs --- a/test/SQLite/Test.hs +++ b/test/SQLite/Test.hs @@ -134,7 +134,6 @@ describe "SQLite specific tests" $ do testAscRandom random_ - testRandomMath testSqliteRandom testSqliteSum testSqliteTwoAscFields diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -19,4 +19,3 @@ sequential $ MySQL.spec describe "Postgresql" $ do sequential $ Postgres.spec -