esqueleto 3.5.8.1 → 3.5.8.2

raw patch · 11 files changed

+674/−69 lines, 11 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• changelog.md +17/−1
• esqueleto.cabal +1/−1
• src/Database/Esqueleto.hs +1/−0
• src/Database/Esqueleto/Experimental.hs +5/−0
• src/Database/Esqueleto/Experimental/From/Join.hs +164/−18
• src/Database/Esqueleto/Internal/Internal.hs +157/−20
• src/Database/Esqueleto/Legacy.hs +1/−0
• src/Database/Esqueleto/PostgreSQL.hs +44/−1
• src/Database/Esqueleto/Record.hs +3/−3
• test/Common/Test.hs +83/−24
• test/PostgreSQL/Test.hs +198/−1

@@ -1,3 +1,19 @@+3.5.9.0+========+- @9999years+    - #350+      - Add `GetFirstTable`, `getTable`, `getTableMaybe` helpers for selecting+        tables from `:&` chains+- @josephsumabat+    - [#339](https://github.com/bitemyapp/esqueleto/pull/333)+      - Add `forUpdateOf`, `forShareOf` locking kinds for postgres++3.5.8.2+=======+- @9999years+    - [#327](https://github.com/bitemyapp/esqueleto/pull/327)+        - Fixed a Haddock typo causing documentation to render incorrectly+ 3.5.8.1 ======= - @belevy@@ -22,7 +38,7 @@ ======= - @belevy     - [#334](https://github.com/bitemyapp/esqueleto/pull/334)-        - Fix alias name bug with union and subselect +        - Fix alias name bug with union and subselect  3.5.7.0 =======

@@ -2,7 +2,7 @@  name:           esqueleto -version:        3.5.8.1+version:        3.5.8.2 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.                 .

@@ -83,6 +83,7 @@   , OrderBy   , DistinctOn   , LockingKind(..)+  , LockableEntity(..)   , SqlString     -- ** Joins   , InnerJoin(..)

@@ -174,6 +174,7 @@     , OrderBy     , DistinctOn     , LockingKind(..)+    , LockableEntity(..)     , SqlString        -- ** Joins@@ -184,6 +185,10 @@     , FullOuterJoin(..)     , JoinKind(..)     , OnClauseWithoutMatchingJoinException(..)+      -- *** Join Helpers+    , getTable+    , getTableMaybe+    , GetFirstTable(..)        -- ** SQL backend     , SqlQuery

@@ -2,7 +2,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}@@ -13,7 +12,31 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}  module Database.Esqueleto.Experimental.From.Join-    where+    ( (:&)(..)+    , ValidOnClause+    , on+    , ErrorOnLateral+    , fromJoin+    , HasOnClause+    , innerJoin+    , innerJoinLateral+    , crossJoin+    , crossJoinLateral+    , leftJoin+    , leftJoinLateral+    , rightJoin+    , fullOuterJoin+    , GetFirstTable(..)+    , getTable+    , getTableMaybe+    -- Compatability for old syntax+    , Lateral+    , NotLateral+    , IsLateral+    , DoInnerJoin(..)+    , DoLeftJoin(..)+    , DoCrossJoin(..)+    ) where  import Data.Bifunctor (first) import Data.Kind (Constraint)@@ -25,23 +48,9 @@ import Database.Esqueleto.Experimental.ToMaybe import Database.Esqueleto.Internal.Internal hiding        (From(..), from, fromJoin, on)+import Database.Esqueleto.Internal.PersistentImport (Entity) import GHC.TypeLits --- | A left-precedence pair. Pronounced \"and\". Used to represent expressions--- that have been joined together.------ The precedence behavior can be demonstrated by:------ @--- a :& b :& c == ((a :& b) :& c)--- @------ See the examples at the beginning of this module to see how this--- operator is used in 'JOIN' operations.-data (:&) a b = a :& b-    deriving (Eq, Show)-infixl 2 :&- instance (ToMaybe a, ToMaybe b) => ToMaybe (a :& b) where     type ToMaybeT (a :& b) = (ToMaybeT a :& ToMaybeT b)     toMaybe (a :& b) = (toMaybe a :& toMaybe b)@@ -331,7 +340,145 @@          `rightJoin`,          `fullOuterJoin` +-- | Typeclass for selecting tables using type application syntax.+--+-- If you have a long chain of tables joined with `(:&)`, like+-- @a :& b :& c :& d@, then @getTable \@c (a :& b :& c :& d)@ will give you the+-- @c@ table back.+--+-- Note that this typeclass will only select the first table of the given type;+-- it may be less useful if there's multiple tables of the same type.+--+-- @since 3.5.9.0+class GetFirstTable t ts where+  -- | Get the first table of type `t` from the tables `ts`.+  --+  -- @since 3.5.9.0+  getFirstTable :: ts -> t +instance GetFirstTable t (t :& ts) where+  getFirstTable (t :& _) = t++instance GetFirstTable t (x :& t) where+  getFirstTable (_ :& t) = t++-- The associativity of (:&) means we do the recursion along the left-hand side.+instance {-# OVERLAPPABLE #-} GetFirstTable t ts => GetFirstTable t (ts :& x) where+  getFirstTable (ts :& _) = getFirstTable ts++-- | Get the first table of a given type from a chain of tables joined with `(:&)`.+--+-- This can make it easier to write queries with a large number of join clauses:+--+-- @+-- select $ do+-- (people :& followers :& blogPosts) <-+--     from $ table \@Person+--     \`innerJoin` table \@Follow+--     \`on\` (\\(person :& follow) ->+--             person ^. PersonId ==. follow ^. FollowFollowed)+--     \`innerJoin` table \@BlogPost+--     \`on\` (\\((getTable \@Follow -> follow) :& blogPost) ->+--             blogPost ^. BlogPostAuthorId ==. follow ^. FollowFollower)+-- where_ (people1 ^. PersonName ==. val \"John\")+-- pure (followers, people2)+-- @+--+-- This example is a bit trivial, but once you've joined five or six tables it+-- becomes enormously helpful. The above example uses a @ViewPattern@ to call+-- the function and assign the variable directly, but you can also imagine it+-- being written like this:+--+-- @+--     \`on\` (\\(prev :& blogPost) ->+--             let+--                 follow = getTable \@Follow prev+--              in+--                 blogPost ^. BlogPostAuthorId ==. follow ^. FollowFollower)+-- @+--+-- This function will pluck out the first table that matches the applied type,+-- so if you join on the same table multiple times, it will always select the+-- first one provided.+--+-- The `(:&)` operator associates so that the left hand side can be a wildcard+-- for an arbitrary amount of nesting, and the "most recent" or "newest" table+-- in a join sequence is always available on the rightmost - so @(prev :& bar)@+-- is a pattern that matches @bar@ table (the most recent table added) and+-- @prev@ tables (all prior tables in the join match).+--+-- By calling 'getTable' on the @prev@, you can select exactly the table you+-- want, allowing you to omit a large number of spurious pattern matches.+-- Consider a query that does several @LEFT JOIN@ on a first table:+--+-- @+-- SELECT *+-- FROM person+-- LEFT JOIN car+--   ON person.id = car.person_id+-- LEFT JOIN bike+--   ON person.id = bike.person_id+-- LEFT JOIN food+--   ON person.id = food.person_id+-- LEFT JOIN address+--   ON person.id = address.person_id+-- @+--+-- The final 'on' clause in esqueleto would look like this:+--+-- @+--     \`on\` do+--         \\(person :& _car :& _bike :& _food :& address) ->+--             person.id ==. address.personId+-- @+--+-- First, we can change it to a @prev :& newest@ match. We can do this because+-- of the operator associativity. This is kind of like how a list @:@ operator+-- associates, but in the other direction: @a : (b : c) = a : b : c@.+--+-- @+--     \`on\` do+--         \\(prev :& address) ->+--             let (person :& _car :& _bike :& _food) = prev+--              in person.id ==. address.personId+-- @+--+-- Then, we can use 'getTable' to select the @Person@ table directly, instead of+-- pattern matching manually.+--+-- @+--     \`on\` do+--         \\(prev :& address) ->+--             let person = getTable \@Person prev+--              in person.id ==. address.personId+-- @+--+-- Finally, we can use a @ViewPattern@ language extension to "inline" the+-- access.+--+-- @+--     \`on\` do+--         \\((getTable \@Person -> person) :& address) ->+--            person.id ==. address.personId+-- @+--+-- With this form, you do not need to be concerned about the number and wildcard+-- status of tables that do not matter to the specific @ON@ clause.+--+-- @since 3.5.9.0+getTable :: forall t ts. GetFirstTable (SqlExpr (Entity t)) ts+         => ts+         -> SqlExpr (Entity t)+getTable = getFirstTable++-- | A variant of `getTable` that operates on possibly-null entities.+--+-- @since 3.5.9.0+getTableMaybe :: forall t ts. GetFirstTable (SqlExpr (Maybe (Entity t))) ts+              => ts+              -> SqlExpr (Maybe (Entity t))+getTableMaybe = getFirstTable+ ------ Compatibility for old syntax  data Lateral@@ -423,4 +570,3 @@          , rhs ~ (b, (ma :& mb) -> SqlExpr (Value Bool))          ) => ToFrom (FullOuterJoin a rhs) (ma :& mb) where     toFrom (FullOuterJoin a b) = fullOuterJoin a b-

@@ -1,19 +1,21 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE TypeApplications #-}-{-# language DerivingStrategies, GeneralizedNewtypeDeriving #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}  {-# OPTIONS_GHC -fno-warn-redundant-constraints #-}@@ -26,8 +28,6 @@ -- tracker so we can safely support it. module Database.Esqueleto.Internal.Internal where -import Data.List.NonEmpty (NonEmpty(..))-import qualified Data.List.NonEmpty as NEL import Control.Applicative ((<|>)) import Control.Arrow (first, (***)) import Control.Exception (Exception, throw, throwIO)@@ -38,6 +38,8 @@ import Data.Acquire (Acquire, allocateAcquire, with) import Data.Int (Int64) import Data.List (intersperse)+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NEL import qualified Data.Maybe as Maybe #if __GLASGOW_HASKELL__ < 804 import Data.Semigroup@@ -46,9 +48,12 @@ import qualified Control.Monad.Trans.State as S import qualified Control.Monad.Trans.Writer as W import qualified Data.ByteString as B+import Data.Coerce (coerce) import qualified Data.Conduit as C import qualified Data.Conduit.List as CL import qualified Data.HashSet as HS+import Data.Kind (Type)+import qualified Data.List as List import qualified Data.Map.Strict as Map import qualified Data.Monoid as Monoid import Data.Proxy (Proxy(..))@@ -60,18 +65,17 @@ import Data.Typeable (Typeable) import Database.Esqueleto.Internal.ExprParser (TableAccess(..), parseOnExpr) import Database.Esqueleto.Internal.PersistentImport-import Database.Persist.SqlBackend+import Database.Persist (EntityNameDB(..), FieldNameDB(..), SymbolToField(..)) import qualified Database.Persist import Database.Persist.Sql.Util        ( entityColumnCount-       , keyAndEntityColumnNames        , isIdField+       , keyAndEntityColumnNames        , parseEntityValues        )-import Text.Blaze.Html (Html)-import Data.Coerce (coerce)-import Data.Kind (Type)+import Database.Persist.SqlBackend import GHC.Records+import Text.Blaze.Html (Html)  -- | (Internal) Start a 'from' query with an entity. 'from' -- does two kinds of magic using 'fromStart', 'fromJoin' and@@ -395,14 +399,21 @@  -- | Add a locking clause to the query.  Please read -- 'LockingKind' documentation and your RDBMS manual.+-- Unsafe since not all locking clauses are implemented for every RDBMS -- -- If multiple calls to 'locking' are made on the same query, -- the last one is used. -- -- @since 2.2.7 locking :: LockingKind -> SqlQuery ()-locking kind = Q $ W.tell mempty { sdLockingClause = Monoid.Last (Just kind) }+locking kind = putLocking $ LegacyLockingClause kind +-- | Helper to add a any type of locking clause to a query+--+-- @since 3.5.9.0+putLocking :: LockingClause -> SqlQuery ()+putLocking clause = Q $ W.tell mempty { sdLockingClause = clause }+ {-#   DEPRECATED     sub_select@@ -1396,6 +1407,21 @@ -- | Phantom type used by 'insertSelect'. data Insertion a +-- | A left-precedence pair. Pronounced \"and\". Used to represent expressions+-- that have been joined together.+--+-- The precedence behavior can be demonstrated by:+--+-- @+-- a :& b :& c == ((a :& b) :& c)+-- @+--+-- See the examples at the beginning of this module to see how this+-- operator is used in 'JOIN' operations.+data (:&) a b = a :& b+    deriving (Eq, Show)+infixl 2 :&+ -- | Different kinds of locking clauses supported by 'locking'. -- -- Note that each RDBMS has different locking support.  The@@ -1425,6 +1451,75 @@       --       -- @since 2.2.7 +-- | Postgres specific locking, used only internally+--+-- @since 3.5.9.0+data PostgresLockingKind =+    PostgresLockingKind+        {+          postgresRowLevelLockStrength :: PostgresRowLevelLockStrength+        , postgresLockingOfClause :: Maybe LockingOfClause+        , postgresOnLockedBehavior :: OnLockedBehavior+        }++-- Arranged in order of lock strength+data PostgresRowLevelLockStrength =+    PostgresForUpdate+    | PostgresForShare+  deriving (Ord, Eq)++data LockingOfClause where+    LockingOfClause :: LockableEntity a => a -> LockingOfClause++data OnLockedBehavior =+    NoWait+    -- ^ @NOWAIT@ syntax locking behaviour.+    --  query excutes immediately failing on locked rows+    --+    -- @since 3.5.9.0+      | SkipLocked+    -- ^ @SKIP LOCKED@ syntax locking behaviour.+    --  query skips locked rows+    --+    -- @since 3.5.9.0+      | Wait+    -- ^ default locking behaviour.+    --  query will wait on locked rows+    --+    -- @since 3.5.9.0+      deriving (Ord, Eq, Show)+++-- | Lockable entity+--+-- Example use:+--+-- @+-- select $ do+--     (p :& bp) <- from $+--         table @Person+--         `innerJoin` table @BlogPost+--             `on` do+--                 \(p :& bp) -> p ^. PersonId ==. b ^. BlogPostAuthorId+--     forUpdateOf (p :& b) skipLocked+--     return p+-- @+class LockableEntity a where+    flattenLockableEntity :: a -> NonEmpty LockableSqlExpr++makeLockableEntity :: LockableEntity a => IdentInfo -> a -> (TLB.Builder, [PersistValue])+makeLockableEntity info lockableEntity =+    uncommas' $ Set.toList . Set.fromList $ (\(LockableSqlExpr (ERaw _ f)) -> f Never info) <$> NEL.toList (flattenLockableEntity lockableEntity)++instance PersistEntity val => LockableEntity (SqlExpr (Entity val)) where+    flattenLockableEntity e = LockableSqlExpr e :| []++instance (LockableEntity a, LockableEntity b) => LockableEntity (a :& b) where+    flattenLockableEntity (a :& b) = flattenLockableEntity a <> flattenLockableEntity b++data LockableSqlExpr where+    LockableSqlExpr :: PersistEntity val => (SqlExpr (Entity val)) -> LockableSqlExpr+ -- | Phantom class of data types that are treated as strings by the -- RDBMS.  It has no methods because it's only used to avoid type -- errors such as trying to concatenate integers.@@ -1983,11 +2078,25 @@  instance Monoid LimitClause where   mempty = Limit mzero mzero-  mappend = (<>)  -- | A locking clause.-type LockingClause = Monoid.Last LockingKind+data LockingClause =+    LegacyLockingClause LockingKind+    -- ^ Locking clause not specific to any database implementation+    | PostgresLockingClauses [PostgresLockingKind]+    -- ^ Locking clause specific to postgres+    | NoLockingClause +instance Semigroup LockingClause where+  -- Postgres allows us to have multiple locking clauses+    (<>) (PostgresLockingClauses pleft) (PostgresLockingClauses pright) = PostgresLockingClauses (pleft <> pright)+    (<>) mleft NoLockingClause = mleft+    (<>) _ mright = mright+--+instance Monoid LockingClause where+    mempty = NoLockingClause+    mappend = (<>)+ ----------------------------------------------------------------------  -- | Identifier used for table names.@@ -2820,7 +2929,7 @@         , makeHaving     info havingClause         , makeOrderBy    info orderByClauses         , makeLimit      info limitClause-        , makeLocking         lockingClause+        , makeLocking    info lockingClause         ]  -- | Renders a 'SqlQuery' into a 'Text' value along with the list of@@ -3053,13 +3162,41 @@         v = maybe 0 fromIntegral     in (TLB.fromText limitRaw, mempty) -makeLocking :: LockingClause -> (TLB.Builder, [PersistValue])-makeLocking = flip (,) [] . maybe mempty toTLB . Monoid.getLast-  where-    toTLB ForUpdate           = "\nFOR UPDATE"-    toTLB ForUpdateSkipLocked = "\nFOR UPDATE SKIP LOCKED"-    toTLB ForShare            = "\nFOR SHARE"-    toTLB LockInShareMode     = "\nLOCK IN SHARE MODE"+makeLocking :: IdentInfo -> LockingClause -> (TLB.Builder, [PersistValue])+makeLocking _ (LegacyLockingClause lockingClause) =+    case lockingClause of+        ForUpdate           -> ("\nFOR UPDATE", [])+        ForUpdateSkipLocked -> ("\nFOR UPDATE SKIP LOCKED", [])+        ForShare            -> ("\nFOR SHARE", [])+        LockInShareMode     -> ("\nLOCK IN SHARE MODE", [])+makeLocking info (PostgresLockingClauses clauses) =+    List.foldl' combineBuilderValPairs ("",[]) (makePostgresLockingClauses <$> clauses)+        where+            combineBuilderValPairs (builder1, persistvals1) (builder2,persistvals2) =+                (builder1 <> builder2 <> "\n", persistvals1 <> persistvals2)++            makePostgresLockingClauses :: PostgresLockingKind -> (TLB.Builder , [PersistValue])+            makePostgresLockingClauses l =+                makeLockingStrength (postgresRowLevelLockStrength l)+                    <> plain " "+                    <> makeOfClause (postgresLockingOfClause l)+                    <> plain " "+                    <> makeLockingBehavior (postgresOnLockedBehavior l)+            makeLockingStrength :: PostgresRowLevelLockStrength -> (TLB.Builder, [PersistValue])+            makeLockingStrength PostgresForUpdate = plain "FOR UPDATE"+            makeLockingStrength PostgresForShare = plain "FOR SHARE"++            makeLockingBehavior :: OnLockedBehavior -> (TLB.Builder, [PersistValue])+            makeLockingBehavior NoWait = plain "NO WAIT"+            makeLockingBehavior SkipLocked = plain "SKIP LOCKED"+            makeLockingBehavior Wait = plain ""++            makeOfClause :: Maybe LockingOfClause -> (TLB.Builder, [PersistValue])+            makeOfClause (Just (LockingOfClause lockableEnts)) = plain "OF " <> makeLockableEntity info lockableEnts+            makeOfClause Nothing = plain ""++            plain v = (v,[])+makeLocking _ NoLockingClause = mempty  parens :: TLB.Builder -> TLB.Builder parens b = "(" <> (b <> ")")

@@ -84,6 +84,7 @@   , OrderBy   , DistinctOn   , LockingKind(..)+  , LockableEntity(..)   , SqlString     -- ** Joins   , InnerJoin(..)

@@ -27,6 +27,11 @@     , upsertBy     , insertSelectWithConflict     , insertSelectWithConflictCount+    , noWait+    , wait+    , skipLocked+    , forUpdateOf+    , forShareOf     , filterWhere     , values     -- * Internal@@ -50,7 +55,8 @@ import Data.Time.Clock (UTCTime) import qualified Database.Esqueleto.Experimental as Ex import Database.Esqueleto.Internal.Internal hiding (random_)-import Database.Esqueleto.Internal.PersistentImport hiding (upsert, upsertBy, uniqueFields)+import Database.Esqueleto.Internal.PersistentImport hiding+       (uniqueFields, upsert, upsertBy) import Database.Persist.SqlBackend  -- | (@random()@) Split out into database specific modules@@ -434,3 +440,40 @@             <> "(" <> TLB.fromLazyText colsAliases <> ")"             , params             )++-- | `NO WAIT` syntax for postgres locking+-- error will be thrown if locked rows are attempted to be selected+--+-- @since 3.5.9.0+noWait :: OnLockedBehavior+noWait = NoWait++-- | `SKIP LOCKED` syntax for postgres locking+-- locked rows will be skipped+--+-- @since 3.5.9.0+skipLocked :: OnLockedBehavior+skipLocked = SkipLocked++-- | default behaviour of postgres locks. will attempt to wait for locks to expire+--+-- @since 3.5.9.0+wait :: OnLockedBehavior+wait = Wait++-- | `FOR UPDATE OF` syntax for postgres locking+-- allows locking of specific tables with an update lock in a view or join+--+-- @since 3.5.9.0+forUpdateOf :: LockableEntity a => a -> OnLockedBehavior -> SqlQuery ()+forUpdateOf lockableEntities onLockedBehavior =+  putLocking $ PostgresLockingClauses [PostgresLockingKind PostgresForUpdate (Just $ LockingOfClause lockableEntities) onLockedBehavior]++-- | `FOR SHARE OF` syntax for postgres locking+-- allows locking of specific tables with a share lock in a view or join+--+-- @since 3.5.9.0++forShareOf :: LockableEntity a => a -> OnLockedBehavior -> SqlQuery ()+forShareOf lockableEntities onLockedBehavior =+  putLocking $ PostgresLockingClauses [PostgresLockingKind PostgresForShare (Just $ LockingOfClause lockableEntities) onLockedBehavior]

@@ -37,9 +37,9 @@ -- with data extracted with esqueleto. -- -- Note that because the input record and the @Sql@-prefixed record share field--- names, the @{-# LANGUAGE DuplicateRecordFields #-}@ extension is required in--- modules that use `deriveEsqueletoRecord`. Additionally, the @{-# LANGUAGE--- TypeApplications #-}@ extension is required for some of the generated code.+-- names, the @{-\# LANGUAGE DuplicateRecordFields \#-}@ extension is required in+-- modules that use `deriveEsqueletoRecord`. Additionally, the @{-\# LANGUAGE+-- TypeApplications \#-}@ extension is required for some of the generated code. -- -- Given the following record: --

@@ -85,11 +85,12 @@ import qualified Data.Text.Lazy.Builder as TLB import qualified Database.Esqueleto.Internal.ExprParser as P import qualified Database.Esqueleto.Internal.Internal as EI-import qualified UnliftIO.Resource as R+import Database.Esqueleto.PostgreSQL as EP import Database.Persist.Class.PersistEntity+import qualified UnliftIO.Resource as R -import Common.Test.Select import Common.Record (testDeriveEsqueletoRecord)+import Common.Test.Select  -- Test schema -- | this could be achieved with S.fromList, but not all lists@@ -1613,32 +1614,31 @@          asserting $ ret `shouldBe` [ Value (3) ] ---- testLocking :: SpecDb testLocking = do+  let toText conn q =+        let (tlb, _) = EI.toRawSql EI.SELECT (conn, EI.initialIdentState) q+         in TLB.toLazyText tlb+      complexQuery =+        from $ \(p1' `InnerJoin` p2') -> do+        on (p1' ^. PersonName ==. p2' ^. PersonName)+        where_ (p1' ^. PersonFavNum >. val 2)+        orderBy [desc (p2' ^. PersonAge)]+        limit 3+        offset 9+        groupBy (p1' ^. PersonId)+        having (countRows <. val (0 :: Int))+        return (p1', p2')   describe "locking" $ do     -- The locking clause is the last one, so try to use many     -- others to test if it's at the right position.  We don't     -- care about the text of the rest, nor with the RDBMS'     -- reaction to the clause.     let sanityCheck kind syntax = do-          let complexQuery =-                from $ \(p1' `InnerJoin` p2') -> do-                on (p1' ^. PersonName ==. p2' ^. PersonName)-                where_ (p1' ^. PersonFavNum >. val 2)-                orderBy [desc (p2' ^. PersonAge)]-                limit 3-                offset 9-                groupBy (p1' ^. PersonId)-                having (countRows <. val (0 :: Int))-                return (p1', p2')-              queryWithClause1 = do-                r <- complexQuery-                locking kind-                return r+          let queryWithClause1 = do+                 r <- complexQuery+                 locking kind+                 return r               queryWithClause2 = do                 locking ForUpdate                 r <- complexQuery@@ -1648,9 +1648,6 @@               queryWithClause3 = do                 locking kind                 complexQuery-              toText conn q =-                let (tlb, _) = EI.toRawSql EI.SELECT (conn, EI.initialIdentState) q-                in TLB.toLazyText tlb           conn <- ask           [complex, with1, with2, with3] <-             return $@@ -1658,16 +1655,53 @@           let expected = complex <> "\n" <> syntax           asserting $               (with1, with2, with3) `shouldBe` (expected, expected, expected)-     itDb "looks sane for ForUpdate"           $ sanityCheck ForUpdate           "FOR UPDATE"     itDb "looks sane for ForUpdateSkipLocked" $ sanityCheck ForUpdateSkipLocked "FOR UPDATE SKIP LOCKED"     itDb "looks sane for ForShare"            $ sanityCheck ForShare            "FOR SHARE"     itDb "looks sane for LockInShareMode"     $ sanityCheck LockInShareMode     "LOCK IN SHARE MODE" +  describe "Monoid instance" $ do+    let+        multiplePostgresLockingClauses p = do+            EP.forUpdateOf p EP.skipLocked+            EP.forUpdateOf p EP.skipLocked+            EP.forShareOf p EP.skipLocked +        multipleLegacyLockingClauses = do+            locking ForShare+            locking ForUpdate +        multipleLockingQueryPostgresLast = do+            p <- Experimental.from $ table @Person+            multipleLegacyLockingClauses+            multiplePostgresLockingClauses p +        multipleLockingQueryLegacyLast = do+            p <- Experimental.from $ table @Person+            multiplePostgresLockingClauses p+            multipleLegacyLockingClauses +        expectedPostgresQuery = do+            p <- Experimental.from $ table @Person+            EP.forUpdateOf p EP.skipLocked+            EP.forUpdateOf p EP.skipLocked+            EP.forShareOf p EP.skipLocked++        expectedLegacyQuery = do+            p <- Experimental.from $ table @Person+            locking ForUpdate++    itDb "prioritizes last grouping of locks when mixing legacy and postgres specific locks" $ do++        conn <- ask+        let resPostgresLast = toText conn multipleLockingQueryPostgresLast+            resLegacyLast = toText conn multipleLockingQueryLegacyLast+            resExpectedPostgres = toText conn expectedPostgresQuery+            resExpectedLegacy = toText conn expectedLegacyQuery++        asserting $ resPostgresLast `shouldBe` resExpectedPostgres+        asserting $ resLegacyLast `shouldBe` resExpectedLegacy+ testCountingRows :: SpecDb testCountingRows = do   describe "counting rows" $ do@@ -2330,6 +2364,7 @@ tests =     describe "Esqueleto" $ do         testSelect+        testGetTable         testSubSelect         testSelectOne         testSelectSource@@ -2475,3 +2510,27 @@     it "is only supported in GHC 9.2 or above" $ \_ -> do         pending #endif++testGetTable :: SpecDb+testGetTable =+    describe "GetFirstTable" $ do+        itDb "works to make long join chains easier" $ do+            select $ do+                (person :& blogPost :& profile :& reply) <-+                    Experimental.from $+                        table @Person+                        `leftJoin` table @BlogPost+                            `Experimental.on` do+                                \(p :& bp) ->+                                    just (p ^. PersonId) ==. bp ?. BlogPostAuthorId+                        `leftJoin` table @Profile+                            `Experimental.on` do+                                \((getTable @Person -> p) :& profile) ->+                                    just (p ^. PersonId) ==. profile ?. ProfilePerson+                        `leftJoin` table @Reply+                            `Experimental.on` do+                                \((getTable @Person -> p) :& reply) ->+                                    just (p ^. PersonId) ==. reply ?. ReplyGuy+                pure (person, blogPost, profile, reply)+            asserting noExceptions+

@@ -12,10 +12,11 @@ module PostgreSQL.Test where  import Control.Arrow ((&&&))+import Control.Concurrent (forkIO) import Control.Monad (void, when) import Control.Monad.IO.Class (MonadIO(liftIO)) import Control.Monad.Logger (runNoLoggingT, runStderrLoggingT)-import Control.Monad.Trans.Reader (ReaderT, ask, mapReaderT)+import Control.Monad.Trans.Reader (ReaderT, ask, mapReaderT, runReaderT) import qualified Control.Monad.Trans.Resource as R import Data.Aeson hiding (Value) import qualified Data.Aeson as A (Value)@@ -31,6 +32,8 @@ import Data.Ord (comparing) import qualified Data.Text as T import qualified Data.Text.Encoding as TE+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TLB import Data.Time import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime) import Database.Esqueleto hiding (random_)@@ -41,10 +44,12 @@ import qualified Database.Esqueleto.PostgreSQL as EP import Database.Esqueleto.PostgreSQL.JSON hiding ((-.), (?.), (||.)) import qualified Database.Esqueleto.PostgreSQL.JSON as JSON+import qualified Database.Persist.Class as P import Database.Persist.Postgresql (createPostgresqlPool, withPostgresqlConn) import Database.PostgreSQL.Simple (ExecStatus(..), SqlError(..)) import System.Environment import Test.Hspec+import Test.Hspec.Core.Spec (sequential) import Test.Hspec.QuickCheck  import Common.Test@@ -1227,6 +1232,197 @@             pure res         asserting $ vals `shouldBe` fmap Value [2..11] +testPostgresqlLocking :: SpecDb+testPostgresqlLocking = do+    describe "Monoid instance" $ do+        let toText conn q =+                let (tlb, _) = ES.toRawSql ES.SELECT (conn, ES.initialIdentState) q+                    in TLB.toLazyText tlb+        itDb "concatenates postgres locking clauses" $ do+            let multipleLockingQuery = do+                    p <- Experimental.from $ table @Person+                    EP.forUpdateOf p EP.skipLocked+                    EP.forUpdateOf p EP.skipLocked+                    EP.forShareOf p EP.skipLocked+            conn <- ask+            let res1 = toText conn multipleLockingQuery+                resExpected =+                    TL.unlines+                    [+                      "SELECT 1"+                    ,"FROM \"Person\""+                    ,"FOR UPDATE OF \"Person\" SKIP LOCKED"+                    ,"FOR UPDATE OF \"Person\" SKIP LOCKED"+                    ,"FOR SHARE OF \"Person\" SKIP LOCKED"+                    ]++            asserting $ res1 `shouldBe` resExpected++    describe "For update skip locked locking" $ sequential $ do+        let mkInitialStateForLockingTest connection =+                flip runSqlPool connection $ do+                    p1k <- insert p1+                    p2k <- insert p2+                    p3k <- insert p3+                    blogPosts <- mapM insert'+                        [ BlogPost "A" p1k+                        , BlogPost "B" p2k+                        , BlogPost "C" p3k ]+                    pure ([p1k, p2k, p3k], entityKey <$> blogPosts)+            cleanupLockingTest connection (personKeys, blogPostKeys) =+                flip runSqlPool connection $ do+                    forM_ blogPostKeys P.delete+                    forM_ personKeys P.delete+        aroundWith (\testAction connection -> do+            bracket (mkInitialStateForLockingTest connection) (cleanupLockingTest connection) $ \(personKeys, blogPostKeys) ->+                testAction (connection, personKeys, blogPostKeys)+            ) $ do+                it "skips locked rows for a locking select" $ \(connection, _, _) -> do+                    waitMainThread <- newEmptyMVar++                    let sideThread :: IO Expectation+                        sideThread = do+                            flip runSqlPool connection $ do++                                _ <- takeMVar waitMainThread+                                nonLockedRowsNonSpecified <-+                                    select $ do+                                        p <- Experimental.from $ table @Person+                                        EP.forUpdateOf p EP.skipLocked+                                        return p++                                nonLockedRowsSpecifiedTable <-+                                    select $ do+                                        from $ \(p `LeftOuterJoin` b) -> do+                                            on (p ^. PersonId ==. b ^. BlogPostAuthorId)+                                            EP.forUpdateOf p EP.skipLocked+                                            return p++                                nonLockedRowsSpecifyAllTables <-+                                    select $ do+                                        from $ \(p `InnerJoin` b) -> do+                                            on (p ^. PersonId ==. b ^. BlogPostAuthorId)+                                            EP.forUpdateOf (p :& b) EP.skipLocked+                                            return p++                                pure $ do+                                    nonLockedRowsNonSpecified `shouldBe` []+                                    nonLockedRowsSpecifiedTable `shouldBe` []+                                    nonLockedRowsSpecifyAllTables `shouldBe` []++                    withAsync sideThread $ \sideThreadAsync -> do+                        void $ flip runSqlPool connection $ do+                            void $ select $ do+                                person <- Experimental.from $ table @Person+                                locking ForUpdate+                                pure $ person ^. PersonId++                            _ <- putMVar waitMainThread ()+                            sideThreadAsserts <- wait sideThreadAsync+                            nonLockedRowsAfterUpdate <- select $ do+                                                from $ \(p `LeftOuterJoin` b) -> do+                                                    on (p ^. PersonId ==. b ^. BlogPostAuthorId)+                                                    EP.forUpdateOf p EP.skipLocked+                                                    return p++                            asserting sideThreadAsserts+                            asserting $ length nonLockedRowsAfterUpdate `shouldBe` 3++                it "skips locked rows for a subselect update" $ \(connection, _, _)-> do+                    waitMainThread <- newEmptyMVar++                    let sideThread :: IO Expectation+                        sideThread =+                            flip runSqlPool connection $ do+                                _ <- liftIO $ takeMVar waitMainThread++                                nonLockedRowsSpecifiedTable <-+                                    select $ do+                                        from $ \(p `LeftOuterJoin` b) -> do+                                            on (p ^. PersonId ==. b ^. BlogPostAuthorId)+                                            EP.forUpdateOf p EP.skipLocked+                                            return p++                                liftIO $ print nonLockedRowsSpecifiedTable+                                pure $ length nonLockedRowsSpecifiedTable `shouldBe` 2++                    withAsync sideThread $ \sideThreadAsync -> do+                        void $ flip runSqlPool connection $ do+                            update $ \p -> do+                                set p [ PersonName =. val "ChangedName1" ]+                                where_ $ p ^. PersonId+                                    `in_` subList_select (do+                                            person <- Experimental.from $ table @Person+                                            where_ (person ^. PersonName ==. val "Rachel")+                                            limit 1+                                            locking ForUpdate+                                            pure $ person ^. PersonId)+++                            _ <- putMVar waitMainThread ()+                            sideThreadAsserts <- wait sideThreadAsync+                            nonLockedRowsAfterUpdate <- select $ do+                                                from $ \(p `LeftOuterJoin` b) -> do+                                                    on (p ^. PersonId ==. b ^. BlogPostAuthorId)+                                                    EP.forUpdateOf p EP.skipLocked+                                                    return p++                            liftIO $ print nonLockedRowsAfterUpdate+                            asserting sideThreadAsserts+                            asserting $ length nonLockedRowsAfterUpdate `shouldBe` 3++                it "skips locked rows for a subselect join update" $ \(connection, _, _) -> do+                    waitMainThread <- newEmptyMVar++                    let sideThread :: IO Expectation+                        sideThread =+                            flip runSqlPool connection $ do+                                liftIO $ takeMVar waitMainThread+                                lockedRows <-+                                    select $ do+                                        from $ \(p `LeftOuterJoin` b) -> do+                                            on (p ^. PersonId ==. b ^. BlogPostAuthorId)+                                            where_ (b ^. BlogPostTitle ==. val "A")+                                            EP.forUpdateOf p EP.skipLocked+                                            return p++                                nonLockedRows <-+                                  select $ do+                                        from $ \(p `LeftOuterJoin` b) -> do+                                            on (p ^. PersonId ==. b ^. BlogPostAuthorId)+                                            EP.forUpdateOf p EP.skipLocked+                                            return p++                                pure $ do+                                    lockedRows `shouldBe` []+                                    length nonLockedRows `shouldBe` 2++                    withAsync sideThread $ \sideThreadAsync -> do+                        void $ flip runSqlPool connection $ do+                            update $ \p -> do+                                set p [ PersonName =. val "ChangedName" ]+                                where_ $ p ^. PersonId+                                    `in_` subList_select (do+                                            (people :& blogPosts) <-+                                                Experimental.from $ table @Person+                                                `Experimental.leftJoin` table @BlogPost+                                                `Experimental.on` (\(people :& blogPosts) ->+                                                        just (people ^. PersonId) ==. blogPosts ?. BlogPostAuthorId)+                                            where_ (blogPosts ?. BlogPostTitle ==. just (val "A"))+                                            pure $ people ^. PersonId+                                        )++                            liftIO $ putMVar waitMainThread ()+                            sideThreadAsserts <- wait sideThreadAsync+                            nonLockedRowsAfterUpdate <- select $ do+                                                from $ \(p `LeftOuterJoin` b) -> do+                                                    on (p ^. PersonId ==. b ^. BlogPostAuthorId)+                                                    EP.forUpdateOf p EP.skipLocked+                                                    return p++                            asserting sideThreadAsserts+                            asserting $ length nonLockedRowsAfterUpdate `shouldBe` 3+ -- Since lateral queries arent supported in Sqlite or older versions of mysql -- the test is in the Postgres module testLateralQuery :: SpecDb@@ -1434,6 +1630,7 @@         testLateralQuery         testValuesExpression         testSubselectAliasingBehavior+        testPostgresqlLocking  insertJsonValues :: SqlPersistT IO () insertJsonValues = do