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
2020-11-04 14:01:23 -07:00 · 2020-11-04 14:01:23 -07:00 · 521ac01488
commit 521ac01488
parent eb034458de
13 changed files with 204 additions and 104 deletions
--- a/cabal.project
+++ b/cabal.project
@ -0,0 +1 @@
+packages: .
--- a/changelog.md
+++ b/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
--- a/esqueleto.cabal
+++ b/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: 
-        -Wall 
-        -Wno-redundant-constraints 
+    ghc-options:
+        -Wall
+        -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-postgresql >= 2.10.0 && <2.11
+      , persistent
+      , 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
--- a/examples/Main.hs
+++ b/examples/Main.hs
@ -1,42 +1,44 @@
-{-# LANGUAGE DerivingStrategies, FlexibleContexts           #-}
-{-# LANGUAGE FlexibleInstances          #-}
-{-# LANGUAGE GADTs                      #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses      #-}
-{-# LANGUAGE OverloadedStrings          #-}
-{-# LANGUAGE QuasiQuotes                #-}
-{-# LANGUAGE ScopedTypeVariables        #-}
-{-# LANGUAGE StandaloneDeriving         #-}
-{-# LANGUAGE TemplateHaskell            #-}
-{-# LANGUAGE TypeFamilies               #-}
-{-# LANGUAGE UndecidableInstances       #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -fno-warn-unused-top-binds #-}

 module Main
    ( main
    ) where

-import           Blog
-import           Control.Monad               (void)
-import           Control.Monad               (forM_)
-import           Control.Monad.IO.Class      (MonadIO, liftIO)
-import           Control.Monad.IO.Unlift     (MonadUnliftIO)
-import           Control.Monad.Logger        (MonadLogger)
-import           Control.Monad.Reader        (MonadReader (..), runReaderT)
-import           Control.Monad.Trans.Control (MonadBaseControl)
-import           Data.Monoid                 ((<>))
-import           Database.Esqueleto
-import           Database.Persist.Postgresql (ConnectionString,
-                                              withPostgresqlConn)
-import           Database.Persist.TH         ( AtLeastOneUniqueKey(..)
-                                             , OnlyOneUniqueKey(..)
-                                             , mkDeleteCascade
-                                             , mkMigrate
-                                             , mkPersist
-                                             , persistLowerCase
-                                             , share
-                                             , sqlSettings
-                                             )
+import Blog
+import Control.Monad (void)
+import Control.Monad (forM_)
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Control.Monad.IO.Unlift (MonadUnliftIO)
+import Control.Monad.Logger (MonadLogger)
+import Control.Monad.Reader (MonadReader(..), runReaderT)
+import Control.Monad.Trans.Control (MonadBaseControl)
+import Data.Monoid ((<>))
+import Database.Esqueleto
+import Database.Persist.Postgresql (ConnectionString, withPostgresqlConn)
+import Database.Persist.TH
+       ( AtLeastOneUniqueKey(..)
+       , OnlyOneUniqueKey(..)
+       , mkDeleteCascade
+       , mkMigrate
+       , mkPersist
+       , persistLowerCase
+       , share
+       , sqlSettings
+       )


 share [ mkPersist sqlSettings
--- a/src/Database/Esqueleto/Internal/PersistentImport.hs
+++ b/src/Database/Esqueleto/Internal/PersistentImport.hs
@ -174,4 +174,5 @@ import Database.Persist.Sql hiding
       , (>.)
       , (>=.)
       , (||.)
+       , exists
       )
--- a/src/Database/Esqueleto/PostgreSQL.hs
+++ b/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
-      (throw (UnexpectedCaseErr OperationNotSupported)) -- Postgres backend should have connUpsertSql, if this error is thrown, check changes on persistent
-      (handler sqlB)
-      (connUpsertSql sqlB)
+    case connUpsertSql sqlB of
+        Nothing ->
+            -- Postgres backend should have connUpsertSql, if this error is
+            -- 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.
--- a/stack-8.6.yaml
+++ b/stack-8.6.yaml
@ -5,9 +5,11 @@ packages:
  - 'examples'

 extra-deps:
-  - persistent-2.10.0
-  - persistent-template-2.7.0
-  - persistent-mysql-2.10.0
-  - persistent-postgresql-2.10.0
-  - persistent-sqlite-2.10.0
-  - postgresql-simple-0.6.1
+  - git: https://github.com/yesodweb/persistent
+    commit: 0b8f9f3305c9b60c947565de882abfbfd8cb5702
+    subdirs:
+      - persistent
+      - persistent-template
+      - persistent-mysql
+      - persistent-postgresql
+      - persistent-sqlite
--- a/stack-8.8.yaml
+++ b/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
--- a/stack-8.8.yaml.lock
+++ b/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
--- a/stack.yaml
+++ b/stack.yaml
@ -1 +1 @@
-stack-8.6.yaml
+stack-8.8.yaml
--- a/test/Common/Test.hs
+++ b/test/Common/Test.hs
@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingStrategies #-}
--- a/test/PostgreSQL/MigrateJSON.hs
+++ b/test/PostgreSQL/MigrateJSON.hs
@ -1,17 +1,19 @@
-{-# LANGUAGE FlexibleContexts
-           , GADTs
-           , GeneralizedNewtypeDeriving
-           , DerivingStrategies
-           , StandaloneDeriving
-           , MultiParamTypeClasses
-           , OverloadedStrings
-           , QuasiQuotes
-           , RankNTypes
-           , ScopedTypeVariables
-           , TemplateHaskell
-           , TypeFamilies
-           , UndecidableInstances
- #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
 module PostgreSQL.MigrateJSON where

 import Control.Monad.Trans.Resource (ResourceT)
--- a/test/PostgreSQL/Test.hs
+++ b/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
-        liftIO $ diffUTCTime nowUtc now `shouldSatisfy` (< halfSecond)
+        -- | Get the time diff and check it's less than a second
+        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
-    tests run
+    hspec $ do
+        tests run

-    describe "Test PostgreSQL locking" $ do
-      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 "Test PostgreSQL locking" $ do
+            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

 run, runSilent, runVerbose :: Run
 runSilent  act = runNoLoggingT     $ run_worker act