Support persistent-2.11 (#226)

* Support persistent-2.11

* sigh

* woop woop

* use hackage

* cpp so we don't have to tighten bounds

* add changelog entry

* lmao timing attacks

* no

cabal.project

@@ -0,0 +1 @@
+packages: .

changelog.md

@@ -1,8 +1,11 @@
-3.4.0.1
+3.4.0.1 (unreleased)
 =======
 - @arthurxavierx
   - [#221](https://github.com/bitemyapp/esqueleto/pull/221)
     - Deprecate `ToAliasT` and `ToAliasReferenceT`
+- @parsonsmatt
+  - [#226](https://github.com/bitemyapp/esqueleto/pull/226)
+    - Support `persistent-2.11`
 - @belevy
   - [#225](https://github.com/bitemyapp/esqueleto/pull/225)
     - Simplify `ToFromT` extracting the overlapping and type error instances

esqueleto.cabal

@@ -53,7 +53,7 @@ library
       , conduit >=1.3
       , containers
       , monad-logger
-      , persistent >=2.10.0 && <2.11
+      , persistent >=2.10.0 && <2.12
       , resourcet >=1.2
       , tagged >=0.2
       , text >=0.11 && <1.3
@@ -61,16 +61,16 @@ library
       , transformers >=0.2
       , unliftio
       , unordered-containers >=0.2
-    ghc-options: 
+    ghc-options:
-        -Wall 
+        -Wall
-        -Wno-redundant-constraints 
+        -Wno-redundant-constraints
         -Wincomplete-uni-patterns
         -Wincomplete-record-updates
         -Wpartial-fields
         -Wmissing-home-modules
         -Widentities
         -Wredundant-constraints
-        -Wcpp-undef 
+        -Wcpp-undef
         -Wcpp-undef
         -Wmonomorphism-restriction
     default-language: Haskell2010
@@ -98,7 +98,7 @@ test-suite mysql
       , mtl
       , mysql
       , mysql-simple
-      , persistent >=2.8.0 && <2.11
+      , persistent
       , persistent-mysql
       , persistent-template
       , resourcet >=1.2
@@ -119,7 +119,7 @@ test-suite postgresql
         Paths_esqueleto
     hs-source-dirs:
         test
-    ghc-options: -Wall
+    ghc-options: -Wall -threaded
     build-depends:
         base >=4.8 && <5.0
       , aeson
@@ -133,8 +133,8 @@ test-suite postgresql
       , hspec
       , monad-logger
       , mtl
-      , persistent >=2.10.0 && <2.11
+      , persistent
-      , persistent-postgresql >= 2.10.0 && <2.11
+      , persistent-postgresql
       , persistent-template
       , postgresql-libpq
       , postgresql-simple
@@ -169,7 +169,7 @@ test-suite sqlite
       , hspec
       , monad-logger
       , mtl
-      , persistent >=2.8.0 && <2.11
+      , persistent
       , persistent-sqlite
       , persistent-template
       , resourcet >=1.2

examples/Main.hs

@@ -1,42 +1,44 @@
-{-# LANGUAGE DerivingStrategies, FlexibleContexts           #-}
+{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE GADTs                      #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes                #-}
+{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE StandaloneDeriving         #-}
+{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TemplateHaskell            #-}
+{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE UndecidableInstances       #-}
+{-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
 
 module Main
     ( main
     ) where
 
-import           Blog
+import Blog
-import           Control.Monad               (void)
+import Control.Monad (void)
-import           Control.Monad               (forM_)
+import Control.Monad (forM_)
-import           Control.Monad.IO.Class      (MonadIO, liftIO)
+import Control.Monad.IO.Class (MonadIO, liftIO)
-import           Control.Monad.IO.Unlift     (MonadUnliftIO)
+import Control.Monad.IO.Unlift (MonadUnliftIO)
-import           Control.Monad.Logger        (MonadLogger)
+import Control.Monad.Logger (MonadLogger)
-import           Control.Monad.Reader        (MonadReader (..), runReaderT)
+import Control.Monad.Reader (MonadReader(..), runReaderT)
-import           Control.Monad.Trans.Control (MonadBaseControl)
+import Control.Monad.Trans.Control (MonadBaseControl)
-import           Data.Monoid                 ((<>))
+import Data.Monoid ((<>))
-import           Database.Esqueleto
+import Database.Esqueleto
-import           Database.Persist.Postgresql (ConnectionString,
+import Database.Persist.Postgresql (ConnectionString, withPostgresqlConn)
-                                              withPostgresqlConn)
+import Database.Persist.TH
-import           Database.Persist.TH         ( AtLeastOneUniqueKey(..)
+       ( AtLeastOneUniqueKey(..)
-                                             , OnlyOneUniqueKey(..)
+       , OnlyOneUniqueKey(..)
-                                             , mkDeleteCascade
+       , mkDeleteCascade
-                                             , mkMigrate
+       , mkMigrate
-                                             , mkPersist
+       , mkPersist
-                                             , persistLowerCase
+       , persistLowerCase
-                                             , share
+       , share
-                                             , sqlSettings
+       , sqlSettings
-                                             )
+       )
 
 
 share [ mkPersist sqlSettings

src/Database/Esqueleto/Internal/PersistentImport.hs

@@ -174,4 +174,5 @@ import Database.Persist.Sql hiding
        , (>.)
        , (>=.)
        , (||.)
+       , exists
        )

src/Database/Esqueleto/PostgreSQL.hs

@@ -40,6 +40,7 @@ import Control.Monad.IO.Class (MonadIO(..))
 import qualified Control.Monad.Trans.Reader as R
 import Data.Int (Int64)
 import Data.List.NonEmpty (NonEmpty((:|)))
+import qualified Data.List.NonEmpty as NonEmpty
 import Data.Proxy (Proxy(..))
 import qualified Data.Text.Internal.Builder as TLB
 import Data.Time.Clock (UTCTime)
@@ -205,17 +206,33 @@ upsertBy
     -- ^ the record in the database after the operation
 upsertBy uniqueKey record updates = do
     sqlB <- R.ask
-    maybe
+    case connUpsertSql sqlB of
-      (throw (UnexpectedCaseErr OperationNotSupported)) -- Postgres backend should have connUpsertSql, if this error is thrown, check changes on persistent
+        Nothing ->
-      (handler sqlB)
+            -- Postgres backend should have connUpsertSql, if this error is
-      (connUpsertSql sqlB)
+            -- thrown, check changes on persistent
+            throw (UnexpectedCaseErr OperationNotSupported)
+        Just upsertSql ->
+            handler sqlB upsertSql
   where
     addVals l = map toPersistValue (toPersistFields record) ++ l ++ persistUniqueToValues uniqueKey
     entDef = entityDef (Just record)
-    uDef = toUniqueDef uniqueKey
     updatesText conn = first builderToText $ renderUpdates conn updates
+#if MIN_VERSION_persistent(2,11,0)
+    uniqueFields = NonEmpty.fromList (persistUniqueToFieldNames uniqueKey)
+    handler sqlB upsertSql = do
+        let (updateText, updateVals) =
+                updatesText sqlB
+            queryText =
+                upsertSql entDef uniqueFields updateText
+            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
 
 -- | Inserts into a table the results of a query similar to 'insertSelect' but allows
 -- to update values that violate a constraint during insertions.

stack-8.6.yaml

@@ -5,9 +5,11 @@ packages:
   - 'examples'
 
 extra-deps:
-  - persistent-2.10.0
+  - git: https://github.com/yesodweb/persistent
-  - persistent-template-2.7.0
+    commit: 0b8f9f3305c9b60c947565de882abfbfd8cb5702
-  - persistent-mysql-2.10.0
+    subdirs:
-  - persistent-postgresql-2.10.0
+      - persistent
-  - persistent-sqlite-2.10.0
+      - persistent-template
-  - postgresql-simple-0.6.1
+      - persistent-mysql
+      - persistent-postgresql
+      - persistent-sqlite

stack-8.8.yaml

@@ -3,3 +3,10 @@ resolver: lts-16.14
 packages:
   - '.'
   - 'examples'
+
+extra-deps:
+- persistent-2.11.0.0
+- persistent-template-2.9.1.0
+- persistent-mysql-2.10.3
+- persistent-postgresql-2.11.0.0
+- persistent-sqlite-2.11.0.0

stack-8.8.yaml.lock

@@ -3,7 +3,72 @@
 # For more information, please see the documentation at:
 #   https://docs.haskellstack.org/en/stable/lock_files
 
-packages: []
+packages:
+- completed:
+    subdir: persistent
+    name: persistent
+    version: 2.11.0.0
+    git: https://github.com/yesodweb/persistent
+    pantry-tree:
+      size: 2099
+      sha256: cd4d895557a60b40543c4a6804d32346a1c14c39e28658bb6852d8f4904ef1de
+    commit: 0b8f9f3305c9b60c947565de882abfbfd8cb5702
+  original:
+    subdir: persistent
+    git: https://github.com/yesodweb/persistent
+    commit: 0b8f9f3305c9b60c947565de882abfbfd8cb5702
+- completed:
+    subdir: persistent-template
+    name: persistent-template
+    version: '2.9'
+    git: https://github.com/yesodweb/persistent
+    pantry-tree:
+      size: 620
+      sha256: 0602872c9c38ccc6966b4a1fd1d102a345f94ad855077157d588536ee6803343
+    commit: 0b8f9f3305c9b60c947565de882abfbfd8cb5702
+  original:
+    subdir: persistent-template
+    git: https://github.com/yesodweb/persistent
+    commit: 0b8f9f3305c9b60c947565de882abfbfd8cb5702
+- completed:
+    subdir: persistent-mysql
+    name: persistent-mysql
+    version: 2.10.3
+    git: https://github.com/yesodweb/persistent
+    pantry-tree:
+      size: 577
+      sha256: a3b9d2ef77af25dca203a4dbe2857b6a1d4e421bbe376f261288e9a8ebfda28f
+    commit: 0b8f9f3305c9b60c947565de882abfbfd8cb5702
+  original:
+    subdir: persistent-mysql
+    git: https://github.com/yesodweb/persistent
+    commit: 0b8f9f3305c9b60c947565de882abfbfd8cb5702
+- completed:
+    subdir: persistent-postgresql
+    name: persistent-postgresql
+    version: 2.11.0.0
+    git: https://github.com/yesodweb/persistent
+    pantry-tree:
+      size: 907
+      sha256: 6f1ad1c5b0b22cf455c6b1b4551a749d21bb72042597450c8ef9ff1eb5a74782
+    commit: 0b8f9f3305c9b60c947565de882abfbfd8cb5702
+  original:
+    subdir: persistent-postgresql
+    git: https://github.com/yesodweb/persistent
+    commit: 0b8f9f3305c9b60c947565de882abfbfd8cb5702
+- completed:
+    subdir: persistent-sqlite
+    name: persistent-sqlite
+    version: 2.11.0.0
+    git: https://github.com/yesodweb/persistent
+    pantry-tree:
+      size: 891
+      sha256: fc9106077e16b406a5a823c732e3b543822a530f2befc446e49acf68797f6d42
+    commit: 0b8f9f3305c9b60c947565de882abfbfd8cb5702
+  original:
+    subdir: persistent-sqlite
+    git: https://github.com/yesodweb/persistent
+    commit: 0b8f9f3305c9b60c947565de882abfbfd8cb5702
 snapshots:
 - completed:
     size: 532382

stack.yaml

@@ -1 +1 @@
-stack-8.6.yaml
+stack-8.8.yaml

test/Common/Test.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingStrategies #-}

test/PostgreSQL/MigrateJSON.hs

@@ -1,17 +1,19 @@
-{-# LANGUAGE FlexibleContexts
+{-# LANGUAGE DataKinds #-}
-           , GADTs
+{-# LANGUAGE DerivingStrategies #-}
-           , GeneralizedNewtypeDeriving
+{-# LANGUAGE FlexibleContexts #-}
-           , DerivingStrategies
+{-# LANGUAGE FlexibleInstances #-}
-           , StandaloneDeriving
+{-# LANGUAGE GADTs #-}
-           , MultiParamTypeClasses
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-           , OverloadedStrings
+{-# LANGUAGE MultiParamTypeClasses #-}
-           , QuasiQuotes
+{-# LANGUAGE OverloadedStrings #-}
-           , RankNTypes
+{-# LANGUAGE QuasiQuotes #-}
-           , ScopedTypeVariables
+{-# LANGUAGE RankNTypes #-}
-           , TemplateHaskell
+{-# LANGUAGE ScopedTypeVariables #-}
-           , TypeFamilies
+{-# LANGUAGE StandaloneDeriving #-}
-           , UndecidableInstances
+{-# LANGUAGE TemplateHaskell #-}
- #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
 module PostgreSQL.MigrateJSON where
 
 import Control.Monad.Trans.Resource (ResourceT)

test/PostgreSQL/Test.hs

@@ -559,7 +559,7 @@ testPostgresModule = do
       run $ do
         nowDb <- select $ return EP.now_
         nowUtc <- liftIO getCurrentTime
-        let halfSecond = realToFrac (0.5 :: Double)
+        let oneSecond = realToFrac (1 :: Double)
 
         -- | Check the result is not null
         liftIO $ nowDb `shouldSatisfy` (not . null)
@@ -567,8 +567,8 @@ testPostgresModule = do
         -- | Unpack the now value
         let (Value now: _) = nowDb
 
-        -- | Get the time diff and check it's less than half a second
+        -- | Get the time diff and check it's less than a second
-        liftIO $ diffUTCTime nowUtc now `shouldSatisfy` (< halfSecond)
+        liftIO $ diffUTCTime nowUtc now `shouldSatisfy` (< oneSecond)
 
 
 --------------- JSON --------------- JSON --------------- JSON ---------------
@@ -1346,39 +1346,38 @@ selectJSON f = select $ from $ \v -> do
 
 main :: IO ()
 main = do
-  hspec $ do
+    hspec $ do
-    tests run
+        tests run
 
-    describe "Test PostgreSQL locking" $ do
+        describe "Test PostgreSQL locking" $ do
-      testLocking withConn
+            testLocking withConn
-
-    describe "PostgreSQL specific tests" $ do
-      testAscRandom random_ run
-      testRandomMath run
-      testSelectDistinctOn
-      testPostgresModule
-      testPostgresqlOneAscOneDesc
-      testPostgresqlTwoAscFields
-      testPostgresqlSum
-      testPostgresqlRandom
-      testPostgresqlUpdate
-      testPostgresqlCoalesce
-      testPostgresqlTextFunctions
-      testInsertUniqueViolation
-      testUpsert
-      testInsertSelectWithConflict
-      testFilterWhere
-      testCommonTableExpressions
-      describe "PostgreSQL JSON tests" $ do
-        -- NOTE: We only clean the table once, so we
-        -- can use its contents across all JSON tests
-        it "MIGRATE AND CLEAN JSON TABLE" $ run $ do
-          void $ runMigrationSilent migrateJSON
-          cleanJSON
-        testJSONInsertions
-        testJSONOperators
-      testLateralQuery
 
+        describe "PostgreSQL specific tests" $ do
+            testAscRandom random_ run
+            testRandomMath run
+            testSelectDistinctOn
+            testPostgresModule
+            testPostgresqlOneAscOneDesc
+            testPostgresqlTwoAscFields
+            testPostgresqlSum
+            testPostgresqlRandom
+            testPostgresqlUpdate
+            testPostgresqlCoalesce
+            testPostgresqlTextFunctions
+            testInsertUniqueViolation
+            testUpsert
+            testInsertSelectWithConflict
+            testFilterWhere
+            testCommonTableExpressions
+            describe "PostgreSQL JSON tests" $ do
+                -- NOTE: We only clean the table once, so we
+                -- can use its contents across all JSON tests
+                it "MIGRATE AND CLEAN JSON TABLE" $ run $ do
+                    void $ runMigrationSilent migrateJSON
+                    cleanJSON
+                testJSONInsertions
+                testJSONOperators
+            testLateralQuery
 
 run, runSilent, runVerbose :: Run
 runSilent  act = runNoLoggingT     $ run_worker act