diff --git a/cabal.project b/cabal.project new file mode 100644 index 0000000..e6fdbad --- /dev/null +++ b/cabal.project @@ -0,0 +1 @@ +packages: . diff --git a/changelog.md b/changelog.md index 40a3137..465a8df 100644 --- 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 diff --git a/esqueleto.cabal b/esqueleto.cabal index e3ad07d..023e4c1 100644 --- 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 diff --git a/examples/Main.hs b/examples/Main.hs index 8f914d0..451044b 100644 --- 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 diff --git a/src/Database/Esqueleto/Internal/PersistentImport.hs b/src/Database/Esqueleto/Internal/PersistentImport.hs index 0b38b5f..84e8582 100644 --- a/src/Database/Esqueleto/Internal/PersistentImport.hs +++ b/src/Database/Esqueleto/Internal/PersistentImport.hs @@ -174,4 +174,5 @@ import Database.Persist.Sql hiding , (>.) , (>=.) , (||.) + , exists ) diff --git a/src/Database/Esqueleto/PostgreSQL.hs b/src/Database/Esqueleto/PostgreSQL.hs index 026829a..bf571f0 100644 --- 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. diff --git a/stack-8.6.yaml b/stack-8.6.yaml index 3d1a4d4..6077550 100644 --- 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 diff --git a/stack-8.8.yaml b/stack-8.8.yaml index 458c3eb..3ef0be4 100644 --- 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 diff --git a/stack-8.8.yaml.lock b/stack-8.8.yaml.lock index 2c5dc5d..c561bc1 100644 --- 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 diff --git a/stack.yaml b/stack.yaml index 153fe73..413602c 120000 --- a/stack.yaml +++ b/stack.yaml @@ -1 +1 @@ -stack-8.6.yaml \ No newline at end of file +stack-8.8.yaml \ No newline at end of file diff --git a/test/Common/Test.hs b/test/Common/Test.hs index 06517cb..414908e 100644 --- a/test/Common/Test.hs +++ b/test/Common/Test.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} diff --git a/test/PostgreSQL/MigrateJSON.hs b/test/PostgreSQL/MigrateJSON.hs index 41bab89..2899c85 100644 --- 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) diff --git a/test/PostgreSQL/Test.hs b/test/PostgreSQL/Test.hs index ff155d0..b1b3a10 100644 --- 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