diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,10 @@ ## Unreleased changes +## 2.13.0.0 (unreleased) + +* [#1225](https://github.com/yesodweb/persistent/pull/1225) + * Support `persistent-2.13` changes for SqlBackend being made internal. + ## 2.12.0.0 * Decomposed `HaskellName` into `ConstraintNameHS`, `EntityNameHS`, `FieldNameHS`. Decomposed `DBName` into `ConstraintNameDB`, `EntityNameDB`, `FieldNameDB` respectively. [#1174](https://github.com/yesodweb/persistent/pull/1174) diff --git a/persistent-test.cabal b/persistent-test.cabal --- a/persistent-test.cabal +++ b/persistent-test.cabal @@ -1,5 +1,5 @@ name: persistent-test -version: 2.12.0.0 +version: 2.13.0.0 license: MIT license-file: LICENSE author: Michael Snoyman @@ -60,7 +60,6 @@ build-depends: base >= 4.9 && < 5 - , persistent >= 2.12 && < 2.13 , aeson >= 1.0 , blaze-html >= 0.9 , bytestring >= 0.10 @@ -69,11 +68,13 @@ , exceptions >= 0.8 , hspec >= 2.4 , hspec-expectations + , http-api-data , HUnit , monad-control , monad-logger >= 0.3.25 , mtl , path-pieces >= 0.2 + , persistent >= 2.13 && < 2.14 , QuickCheck >= 2.9 , quickcheck-instances >= 0.3 , random >= 1.1 diff --git a/src/CompositeTest.hs b/src/CompositeTest.hs --- a/src/CompositeTest.hs +++ b/src/CompositeTest.hs @@ -7,12 +7,11 @@ import qualified Data.Map as Map import Data.Maybe (isJust) -import Database.Persist.TH (mkDeleteCascade) import Init -- mpsGeneric = False is due to a bug or at least lack of a feature in mkKeyTypeDec TH.hs -share [mkPersist persistSettings { mpsGeneric = False }, mkMigrate "compositeMigrate", mkDeleteCascade persistSettings { mpsGeneric = False }] [persistLowerCase| +share [mkPersist persistSettings { mpsGeneric = False }, mkMigrate "compositeMigrate"] [persistLowerCase| TestParent name String maxlen=20 name2 String maxlen=20 @@ -233,6 +232,8 @@ it "RawSql Entity instance" $ runDb $ do key <- insert p1 + Just x <- get key + x @== p1 newp1 <- rawSql "SELECT ?? FROM test_parent LIMIT 1" [] [Entity key p1] @== newp1 diff --git a/src/ForeignKey.hs b/src/ForeignKey.hs --- a/src/ForeignKey.hs +++ b/src/ForeignKey.hs @@ -8,6 +8,8 @@ import qualified Data.List as List import Init +import Database.Persist.EntityDef.Internal (entityExtra) + -- mpsGeneric = False is due to a bug or at least lack of a feature in mkKeyTypeDec TH.hs share [mkPersist persistSettings { mpsGeneric = False }, mkMigrate "compositeMigrate"] [persistLowerCase| SimpleCascadeChild @@ -204,7 +206,7 @@ , fcOnDelete = Just Cascade } Just refField = - List.find isRefCol (entityFields ed) + List.find isRefCol (getEntityFields ed) it "parses into fieldCascade" $ do fieldCascade refField `shouldBe` expected diff --git a/src/GeneratedColumnTestSQL.hs b/src/GeneratedColumnTestSQL.hs --- a/src/GeneratedColumnTestSQL.hs +++ b/src/GeneratedColumnTestSQL.hs @@ -6,7 +6,7 @@ import Database.Persist.TH import Init -share [mkPersist sqlSettings, mkMigrate "migrate1", mkDeleteCascade sqlSettings] [persistLowerCase| +share [mkPersist sqlSettings, mkMigrate "migrate1"] [persistLowerCase| GenTest sql=gen_test fieldOne Text Maybe fieldTwo Text Maybe @@ -18,7 +18,7 @@ cromulence Int generated=5 |] -share [mkPersist sqlSettings, mkMigrate "migrate2", mkDeleteCascade sqlSettings] [persistLowerCase| +share [mkPersist sqlSettings, mkMigrate "migrate2"] [persistLowerCase| MigrateTestV2 sql=gen_migrate_test sickness Int generated=3 cromulence Int diff --git a/src/Init.hs b/src/Init.hs --- a/src/Init.hs +++ b/src/Init.hs @@ -1,6 +1,8 @@ -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -42,14 +44,16 @@ , liftA2 , changeBackend , Proxy(..) + , UUID(..) + , sqlSettingsUuid ) where #if !MIN_VERSION_monad_logger(0,3,30) -- Needed for GHC versions 7.10.3. Can drop when we drop support for GHC -- 7.10.3 +import qualified Control.Monad.Fail as MonadFail import Control.Monad.IO.Class import Control.Monad.Logger -import qualified Control.Monad.Fail as MonadFail #endif -- needed for backwards compatibility @@ -64,21 +68,35 @@ -- re-exports import Control.Applicative (liftA2, (<|>)) import Control.Exception (SomeException) -import Control.Monad (void, replicateM, liftM, when, forM_) +import Control.Monad (forM_, liftM, replicateM, void, when) import Control.Monad.Fail (MonadFail) import Control.Monad.Reader -import Data.Char (generalCategory, GeneralCategory(..)) -import Data.Fixed (Pico,Micro) +import Data.Char (GeneralCategory(..), generalCategory) +import Data.Fixed (Micro, Pico) +import Data.Proxy import qualified Data.Text as T import Data.Time import Test.Hspec import Test.QuickCheck.Instances () -import Data.Proxy -import Database.Persist.TH (mkPersist, mkMigrate, share, sqlSettings, persistLowerCase, persistUpperCase, MkPersistSettings(..)) +import Data.Aeson (FromJSON, ToJSON, Value(..)) +import qualified Data.Text.Encoding as TE +import Database.Persist.ImplicitIdDef (mkImplicitIdDef) +import Database.Persist.TH + ( MkPersistSettings(..) + , mkMigrate + , mkPersist + , persistLowerCase + , persistUpperCase + , setImplicitIdDef + , share + , sqlSettings + ) +import Web.Internal.HttpApiData +import Web.PathPieces -- testing -import Test.HUnit ((@?=),(@=?), Assertion, assertFailure, assertBool) +import Test.HUnit (Assertion, assertBool, assertFailure, (@=?), (@?=)) import Test.QuickCheck import Control.Monad (unless, (>=>)) @@ -247,3 +265,34 @@ f $ runInBase . (\(ResourceT r) -> r reader') restoreM = ResourceT . const . restoreM #endif + +-- * For implicit ID spec + +newtype UUID = UUID { unUUID :: Text } + deriving stock + (Show, Eq, Ord, Read) + deriving newtype + (ToJSON, FromJSON, FromHttpApiData, ToHttpApiData, PathPiece) + +instance PersistFieldSql UUID where + sqlType _ = SqlOther "UUID" + +instance PersistField UUID where + toPersistValue (UUID txt) = + PersistLiteral_ Escaped (TE.encodeUtf8 txt) + fromPersistValue pv = + case pv of + PersistLiteral_ Escaped bs -> + Right $ UUID (TE.decodeUtf8 bs) + _ -> + Left "Nope" + +sqlSettingsUuid :: Text -> MkPersistSettings +sqlSettingsUuid defExpr = + let + uuidDef = + mkImplicitIdDef @UUID defExpr + settings = + setImplicitIdDef uuidDef sqlSettings + in + settings diff --git a/src/LongIdentifierTest.hs b/src/LongIdentifierTest.hs --- a/src/LongIdentifierTest.hs +++ b/src/LongIdentifierTest.hs @@ -18,7 +18,7 @@ -- This test creates very long identifier names. The generated foreign key is over the length limit for Postgres and MySQL -- persistent-postgresql handles this by truncating foreign key names using the same algorithm that Postgres itself does (see 'refName' in Postgresql.hs) -- MySQL currently doesn't run this test, and needs truncation logic for it to pass. -share [mkPersist sqlSettings, mkMigrate "migration", mkDeleteCascade sqlSettings] [persistLowerCase| +share [mkPersist sqlSettings, mkMigrate "migration"] [persistLowerCase| TableAnExtremelyFantasticallySuperLongNameParent field1 Int TableAnExtremelyFantasticallySuperLongNameChild diff --git a/src/MigrationOnlyTest.hs b/src/MigrationOnlyTest.hs --- a/src/MigrationOnlyTest.hs +++ b/src/MigrationOnlyTest.hs @@ -1,11 +1,14 @@ -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeApplications, UndecidableInstances #-} + {-# OPTIONS_GHC -Wno-unused-top-binds #-} + module MigrationOnlyTest (specsWith, migrateAll1, migrateAll2) where import qualified Data.Text as T import Database.Persist.TH import Init +import Database.Persist.EntityDef share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "migrateAll1"] [persistLowerCase| TwoField1 sql=two_field @@ -15,7 +18,7 @@ deriving Eq Show |] -share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "migrateAll2", mkDeleteCascade sqlSettings] [persistLowerCase| +share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "migrateAll2"] [persistLowerCase| TwoField field1 Int field2 T.Text @@ -33,6 +36,27 @@ -> Maybe (ReaderT backend m a) -> Spec specsWith runDb mmigrate = describe "MigrationOnly field" $ do + let + edef = + entityDef $ Proxy @TwoField + describe "getEntityFields" $ do + let + fields = + getEntityFields edef + it "should have two fields" $ do + length fields `shouldBe` 2 + it "should not have any migration only fields" $ do + fields `shouldSatisfy` all isHaskellField + + describe "getEntityFieldsDatabase" $ do + let + fields = + getEntityFieldsDatabase edef + it "should have three fields" $ do + length fields `shouldBe` 3 + it "should have at one migration only field" $ do + length (filter (not . isHaskellField) fields) `shouldBe` 1 + it "doesn't have the field in the Haskell entity" $ asIO $ runDb $ do sequence_ mmigrate sequence_ mmigrate diff --git a/src/MigrationTest.hs b/src/MigrationTest.hs --- a/src/MigrationTest.hs +++ b/src/MigrationTest.hs @@ -7,7 +7,7 @@ import Init -share [mkPersist sqlSettings, mkMigrate "migrationMigrate", mkDeleteCascade sqlSettings] [persistLowerCase| +share [mkPersist sqlSettings, mkMigrate "migrationMigrate"] [persistLowerCase| Target field1 Int field2 T.Text @@ -23,7 +23,7 @@ Primary pk |] -share [mkPersist sqlSettings, mkMigrate "migrationAddCol", mkDeleteCascade sqlSettings] [persistLowerCase| +share [mkPersist sqlSettings, mkMigrate "migrationAddCol"] [persistLowerCase| Target1 sql=target field1 Int field2 T.Text diff --git a/src/PersistentTest.hs b/src/PersistentTest.hs --- a/src/PersistentTest.hs +++ b/src/PersistentTest.hs @@ -632,80 +632,11 @@ describe "documentation syntax" $ do let edef = entityDef (Proxy :: Proxy Relationship) it "provides comments on entity def" $ do - entityComments edef + getEntityComments edef `shouldBe` Just "This is a doc comment for a relationship.\nYou need to put the pipe character for each line of documentation.\nBut you can resume the doc comments afterwards.\n" it "provides comments on the field" $ do - let [nameField, _] = entityFields edef + let [nameField, _] = getEntityFields edef fieldComments nameField `shouldBe` Just "Fields should be documentable.\n" - - describe "JsonEncoding" $ do - let - subject = - JsonEncoding "Bob" 32 - subjectEntity = - Entity (JsonEncodingKey (jsonEncodingName subject)) subject - - it "encodes without an ID field" $ do - toJSON subjectEntity - `shouldBe` - Object (M.fromList - [ ("name", String "Bob") - , ("age", toJSON (32 :: Int)) - , ("id", String "Bob") - ]) - - it "decodes without an ID field" $ do - let - json_ = encode . Object . M.fromList $ - [ ("name", String "Bob") - , ("age", toJSON (32 :: Int)) - ] - decode json_ - `shouldBe` - Just subjectEntity - - prop "works with a Primary" $ \jsonEncoding -> do - let - ent = - Entity (JsonEncodingKey (jsonEncodingName jsonEncoding)) jsonEncoding - decode (encode ent) - `shouldBe` - Just ent - - prop "excuse me what" $ \j@JsonEncoding{..} -> do - let - ent = - Entity (JsonEncodingKey jsonEncodingName) j - toJSON ent - `shouldBe` - Object (M.fromList - [ ("name", toJSON jsonEncodingName) - , ("age", toJSON jsonEncodingAge) - , ("id", toJSON jsonEncodingName) - ]) - - prop "round trip works with composite key" $ \j@JsonEncoding2{..} -> do - let - key = JsonEncoding2Key jsonEncoding2Name jsonEncoding2Blood - ent = - Entity key j - decode (encode ent) - `shouldBe` - Just ent - - prop "works with a composite key" $ \j@JsonEncoding2{..} -> do - let - key = JsonEncoding2Key jsonEncoding2Name jsonEncoding2Blood - ent = - Entity key j - toJSON ent - `shouldBe` - Object (M.fromList - [ ("name", toJSON jsonEncoding2Name) - , ("age", toJSON jsonEncoding2Age) - , ("blood", toJSON jsonEncoding2Blood) - , ("id", toJSON key) - ]) diff --git a/src/PersistentTestModels.hs b/src/PersistentTestModels.hs --- a/src/PersistentTestModels.hs +++ b/src/PersistentTestModels.hs @@ -6,6 +6,7 @@ import Data.Aeson +import qualified Data.List.NonEmpty as NEL import Data.Proxy import Test.QuickCheck import Database.Persist.Sql @@ -18,7 +19,7 @@ -- just need to ensure this compiles import PersistentTestModelsImports() -share [mkPersist persistSettings { mpsGeneric = True }, mkMigrate "testMigrate", mkDeleteCascade persistSettings, mkSave "_ignoredSave"] [persistUpperCase| +share [mkPersist persistSettings { mpsGeneric = True }, mkMigrate "testMigrate"] [persistUpperCase| -- Dedented comment -- Header-level comment @@ -140,27 +141,6 @@ |] -share [mkMigrate "testNonGenericMigrate", mkPersist sqlSettings] [persistLowerCase| -JsonEncoding json - name Text - age Int - Primary name - deriving Show Eq - -JsonEncoding2 json - name Text - age Int - blood Text - Primary name blood - deriving Show Eq -|] - -instance Arbitrary JsonEncoding where - arbitrary = JsonEncoding <$> arbitrary <*> arbitrary - -instance Arbitrary JsonEncoding2 where - arbitrary = JsonEncoding2 <$> arbitrary <*> arbitrary <*> arbitrary - deriving instance Show (BackendKey backend) => Show (NoPrefix1Generic backend) deriving instance Eq (BackendKey backend) => Eq (NoPrefix1Generic backend) @@ -225,7 +205,7 @@ where unRfoProxy :: proxy (ReverseFieldOrder a) -> Proxy a unRfoProxy _ = Proxy - revFields ed = ed { entityFields = reverse (entityFields ed) } + revFields = overEntityFields reverse toPersistFields = reverse . toPersistFields . unRFO newtype EntityField (ReverseFieldOrder a) b = EFRFO {unEFRFO :: EntityField a b} @@ -233,9 +213,9 @@ fromPersistValues = fmap RFO . fromPersistValues . reverse newtype Unique (ReverseFieldOrder a) = URFO {unURFO :: Unique a } - persistUniqueToFieldNames = reverse . persistUniqueToFieldNames . unURFO + persistUniqueToFieldNames = NEL.reverse . persistUniqueToFieldNames . unURFO persistUniqueToValues = reverse . persistUniqueToValues . unURFO - persistUniqueKeys = map URFO . reverse . persistUniqueKeys . unRFO + persistUniqueKeys = fmap URFO . reverse . persistUniqueKeys . unRFO persistIdField = error "ReverseFieldOrder.persistIdField" fieldLens = error "ReverseFieldOrder.fieldLens" diff --git a/src/RawSqlTest.hs b/src/RawSqlTest.hs --- a/src/RawSqlTest.hs +++ b/src/RawSqlTest.hs @@ -8,6 +8,7 @@ import qualified Data.Text as T import Init +import Database.Persist.SqlBackend import PersistTestPetType import PersistentTestModels @@ -141,7 +142,7 @@ liftIO $ ret @?= [(Single (1::Int), Single (2::Int), Single (3::Int), Single (4::Int), Single (5::Int), Single (6::Int), Single (7::Int), Single (8::Int), Single (9::Int), Single (10::Int), Single (11::Int), Single (12::Int), Single (13::Int), Single (14::Int), Single (15::Int))] getEscape :: MonadReader SqlBackend m => m (Text -> Text) -getEscape = asks connEscapeRawName +getEscape = getEscapeRawNameFunction caseCommitRollback :: Runner SqlBackend m => RunDb SqlBackend m -> Assertion caseCommitRollback runDb = runDb $ do diff --git a/src/Recursive.hs b/src/Recursive.hs --- a/src/Recursive.hs +++ b/src/Recursive.hs @@ -1,16 +1,21 @@ {-# LANGUAGE UndecidableInstances #-} + {-# OPTIONS_GHC -Wno-unused-top-binds #-} + module Recursive (specsWith, recursiveMigrate, cleanup) where import Init share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "recursiveMigrate"] [persistLowerCase| + SubType object [MenuObject] deriving Show Eq + MenuObject sub SubType Maybe deriving Show Eq + |] cleanup diff --git a/src/RenameTest.hs b/src/RenameTest.hs --- a/src/RenameTest.hs +++ b/src/RenameTest.hs @@ -75,9 +75,9 @@ specsWith runDb = describe "rename specs" $ do describe "LowerCaseTable" $ do it "LowerCaseTable has the right sql name" $ do - fieldDB (entityId (entityDef (Proxy @LowerCaseTable))) + fmap fieldDB (getEntityIdField (entityDef (Proxy @LowerCaseTable))) `shouldBe` - FieldNameDB "my_id" + Just (FieldNameDB "my_id") it "user specified id, insertKey, no default=" $ runDb $ do let rec2 = IdTable "Foo2" Nothing @@ -92,7 +92,7 @@ key' @== key it "extra blocks" $ - entityExtra (entityDef (Nothing :: Maybe LowerCaseTable)) @?= + getEntityExtra (entityDef (Nothing :: Maybe LowerCaseTable)) @?= Map.fromList [ ("ExtraBlock", map T.words ["foo bar", "baz", "bin"]) , ("ExtraBlock2", map T.words ["something"]) diff --git a/src/TreeTest.hs b/src/TreeTest.hs --- a/src/TreeTest.hs +++ b/src/TreeTest.hs @@ -5,15 +5,13 @@ import Init -import Database.Persist.TH (mkDeleteCascade) - -- mpsGeneric = False is due to a bug or at least lack of a feature in -- mkKeyTypeDec TH.hs share [ mkPersist persistSettings { mpsGeneric = False } , mkMigrate "treeMigrate" - , mkDeleteCascade persistSettings { mpsGeneric = False } ] [persistLowerCase| + ] [persistLowerCase| Tree sql=trees name Text parent Text Maybe @@ -41,14 +39,14 @@ gp <- getJust kgp treeFkparent gp @== Nothing describe "entityDef" $ do - let EntityDef{..} = entityDef (Proxy :: Proxy Tree) + let ed = entityDef (Proxy :: Proxy Tree) it "has the right haskell name" $ do - entityHaskell `shouldBe` EntityNameHS "Tree" + getEntityHaskellName ed `shouldBe` EntityNameHS "Tree" it "has the right DB name" $ do - entityDB `shouldBe` EntityNameDB "trees" + getEntityDBName ed `shouldBe` EntityNameDB "trees" describe "foreign ref" $ do - let [ForeignDef{..}] = entityForeigns (entityDef (Proxy :: Proxy Tree)) + let [ForeignDef{..}] = getEntityForeignDefs (entityDef (Proxy :: Proxy Tree)) it "has the right haskell name" $ do foreignRefTableHaskell `shouldBe` EntityNameHS "Tree" @@ -60,7 +58,7 @@ ConstraintNameHS "fkparent" it "has the right DB constraint name" $ do foreignConstraintNameDBName `shouldBe` - ConstraintNameDB "treesfkparent" + ConstraintNameDB "treefkparent" it "has the right fields" $ do foreignFields `shouldBe` [ ( (FieldNameHS "parent", FieldNameDB "parent")