persistent-test 2.13.1.2 → 2.13.1.3
raw patch · 7 files changed
+209/−34 lines, 7 filesdep ~persistent
Dependency ranges changed: persistent
Files
- ChangeLog.md +4/−0
- persistent-test.cabal +3/−2
- src/DataTypeTest.hs +2/−0
- src/PersistUniqueTest.hs +127/−31
- src/PersistentTestModels.hs +3/−0
- src/RawSqlTest.hs +2/−1
- src/TypeLitFieldDefsTest.hs +68/−0
ChangeLog.md view
@@ -1,5 +1,9 @@ ## Unreleased changes +## 2.13.1.3++* Support persistent-2.14 with `SafeToInsert` class+ ## 2.13.1.2 * [#1367](https://github.com/yesodweb/persistent/pull/1367),
persistent-test.cabal view
@@ -1,5 +1,5 @@ name: persistent-test-version: 2.13.1.2+version: 2.13.1.3 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -53,6 +53,7 @@ SumTypeTest TransactionLevelTest TreeTest+ TypeLitFieldDefsTest UniqueTest UpsertTest LongIdentifierTest@@ -75,7 +76,7 @@ , monad-logger >= 0.3.25 , mtl , path-pieces >= 0.2- , persistent >= 2.13.3 && < 2.14+ , persistent >= 2.14 && < 2.15 , QuickCheck >= 2.9 , quickcheck-instances >= 0.3 , random >= 1.1
src/DataTypeTest.hs view
@@ -20,6 +20,7 @@ import Test.QuickCheck.Gen (Gen(..)) import Test.QuickCheck.Instances () import Test.QuickCheck.Random (newQCGen)+import Database.Persist.Class.PersistEntity import Database.Persist.TH import Init@@ -91,6 +92,7 @@ , PersistQueryWrite backend , MonadFail m , MonadIO m+ , SafeToInsert entity ) => (db () -> IO ()) -- ^ DB Runner
src/PersistUniqueTest.hs view
@@ -6,43 +6,139 @@ -- mpsGeneric = False is due to a bug or at least lack of a feature in mkKeyTypeDec TH.hs share [mkPersist persistSettings { mpsGeneric = False }, mkMigrate "migration"] [persistLowerCase|- Fo- foo Int- bar Int- Primary foo- UniqueBar bar- deriving Eq Show++Fo+ foo Int+ bar Int+ Primary foo+ UniqueBar bar+ deriving Eq Show++Ba+ foo Int+ baz Int+ UniqueBaz baz+ deriving Eq Show++OnlyPrimaryKey+ foo Int+ name String+ Primary foo+ deriving Eq Show+ |] +deriving stock instance Eq (Unique Fo)+deriving stock instance Show (Unique Fo)++deriving stock instance Show (Unique Ba)+deriving stock instance Eq (Unique Ba)++shouldCompile :: (OnlyOneUniqueKey OnlyPrimaryKey, AtLeastOneUniqueKey OnlyPrimaryKey) => IO ()+shouldCompile = pure ()+ cleanDB :: (MonadIO m, PersistQuery backend, PersistEntityBackend Fo ~ backend) => ReaderT backend m () cleanDB = do deleteWhere ([] :: [Filter Fo]) specsWith :: Runner SqlBackend m => RunDb SqlBackend m -> Spec-specsWith runDb = describe "custom primary key" $ do- it "getBy" $ runDb $ do- let b = 5- k <- insert $ Fo 3 b- Just vk <- get k- Just vu <- getBy (UniqueBar b)- vu @== Entity k vk- it "insertUniqueEntity" $ runDb $ do- let fo = Fo 3 5- Just (Entity _ insertedFoValue) <- insertUniqueEntity fo- Nothing <- insertUniqueEntity fo- fo @== insertedFoValue- it "checkUniqueUpdateable" $ runDb $ do- let f = 3- let b = 5- let fo = Fo f b- k <- insert fo- Just _ <- checkUnique fo -- conflicts with itself+specsWith runDb = describe "PersistUniqueTest" $ do+ describe "getBy" $ do+ it "works to pull a record from the database" $ runDb $ do+ let b = 5+ k <- insert Fo { foFoo = 3, foBar = b }+ Just vk <- get k+ Just vu <- getBy (UniqueBar b)+ vu @== Entity k vk - let fo' = Fo (f + 1) b- Just _ <- checkUnique fo' -- conflicts with fo- Nothing <- checkUniqueUpdateable $ Entity k fo' -- but fo can be updated to fo'+ describe "insertUniqueEntity" $ do+ it "inserts a value if no conflicts are present" $ runDb $ do+ let fo = Fo 3 5+ Just (Entity _ insertedFoValue) <- insertUniqueEntity fo+ fo @== insertedFoValue - let fo'' = Fo (f + 1) (b + 1)- insert_ fo''- Just (UniqueBar conflict) <- checkUniqueUpdateable $ Entity k fo'' -- fo can't be updated to fo''- conflict @== b + 1+ it "does not insert if the record is entirely the same" $ runDb $ do+ let fo = Fo 3 5+ Just (Entity _ insertedFoValue) <- insertUniqueEntity fo+ mresult <- insertUniqueEntity fo+ mresult @== Nothing++ it "does not insert if there is a primary key conflict" $ runDb $ do+ let fo = Fo 3 5+ Just (Entity _ insertedFoValue) <- insertUniqueEntity fo+ mresult <- insertUniqueEntity fo { foFoo = 4 }+ mresult @== Nothing++ it "does not insert if there is a unique key conflict" $ runDb $ do+ let fo = Fo 3 5+ Just (Entity _ insertedFoValue) <- insertUniqueEntity fo+ mresult <- insertUniqueEntity fo { foBar = 4 }+ mresult @== Nothing++ describe "checkUniqueUpdateable" $ do+ describe "with standard id" $ do+ it "returns the unique constraint that failed" $ runDb $ do+ let ba = Ba { baFoo = 1, baBaz = 2 }+ bk <- insert ba+ mresult <- checkUnique ba+ mresult @== Just (UniqueBaz 2)+ it "returns Nothing if no constraint conflict exists" $ runDb $ do+ let ba = Ba { baFoo = 1, baBaz = 2 }+ mresult <- checkUnique ba+ mresult @== Nothing++ describe "with Primary" $ do+ it "conflicts with itself" $ runDb $ do+ let f = 3+ let b = 5+ let fo = Fo f b+ k <- insert fo+ mresult <- checkUnique fo+ mresult @== Just (FoPrimaryKey f)++ it "returns the key that failed" $ runDb $ do+ let f = 3+ let b = 5+ let fo = Fo f b+ k <- insert fo+ _ <- checkUnique fo -- conflicts with itself++ let fo' = Fo (f + 1) b+ Just _ <- checkUnique fo' -- conflicts with fo+ Nothing <- checkUniqueUpdateable $ Entity k fo' -- but fo can be updated to fo'++ let fo'' = Fo (f + 1) (b + 1)+ insert_ fo''+ mresult <- checkUniqueUpdateable $ Entity k fo'' -- fo can't be updated to fo''+ mresult @== Just (FoPrimaryKey (f + 1))++ describe "upsert" $ do+ describe "OnlyPrimaryKey" $ do+ it "can upsert" $ runDb $ do+ let+ record =+ OnlyPrimaryKey+ { onlyPrimaryKeyFoo = 1+ , onlyPrimaryKeyName = "Oh no"+ }+ entity <- upsert record [OnlyPrimaryKeyName =. "Hello"]+ entityVal entity @== record+ entity' <- upsert record [OnlyPrimaryKeyName =. "Hello"]+ entityVal entity' @== record { onlyPrimaryKeyName = "Hello" }++ describe "Fo" $ do+ it "cannot upsert" $ runDb $ do+ -- uncomment to verify+ -- _ <- upsert Fo { foFoo = 1, foBar = 2 } [FoFoo +=. 1]+ pure ()+ it "can upsertBy" $ runDb $ do+ let f = Fo { foFoo = 1, foBar = 2 }+ entity <- upsertBy (FoPrimaryKey 1) f [FoBar +=. 1]+ entityVal entity @== f+ entity' <- upsertBy (FoPrimaryKey 1) f [FoBar +=. 1]+ entityVal entity' @== f { foBar = 1 + foBar f }++ describe "OnlyPrimaryKey" $ do+ it "has unique constraints" $ do+ shouldCompile+
src/PersistentTestModels.hs view
@@ -2,6 +2,9 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE UndecidableInstances #-} -- FIXME++{-# OPTIONS_GHC -ddump-splices #-}+ module PersistentTestModels where import Data.Aeson hiding (Key)
src/RawSqlTest.hs view
@@ -7,6 +7,7 @@ import qualified Data.Conduit.List as CL import qualified Data.Text as T +import Database.Persist.Class.PersistEntity import Init import Database.Persist.SqlBackend import PersistTestPetType@@ -104,7 +105,7 @@ it "OUTER JOIN" $ runDb $ do- let insert' :: (PersistStore backend, PersistEntity val, PersistEntityBackend val ~ BaseBackend backend, MonadIO m)+ let insert' :: (PersistStore backend, PersistEntity val, PersistEntityBackend val ~ BaseBackend backend, MonadIO m, SafeToInsert val) => val -> ReaderT backend m (Key val, val) insert' v = insert v >>= \k -> return (k, v) (p1k, p1) <- insert' $ Person "Mathias" 23 Nothing
+ src/TypeLitFieldDefsTest.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++module TypeLitFieldDefsTest (specsWith, typeLitFieldDefsMigrate) where++import Data.Maybe (fromJust)+import GHC.TypeLits+import Init++newtype Finite (n :: Nat) = Finite Int+ deriving (Show, Eq)++instance PersistField (Finite n) where+ toPersistValue (Finite n) = toPersistValue n+ fromPersistValue = fmap Finite . fromPersistValue++instance PersistFieldSql (Finite n) where+ sqlType _ = sqlType (Proxy :: Proxy Int)++newtype Labelled (t :: Symbol) = Labelled Int+ deriving (Show, Eq)++instance PersistField (Labelled n) where+ toPersistValue (Labelled n) = toPersistValue n+ fromPersistValue = fmap Labelled . fromPersistValue++instance PersistFieldSql (Labelled n) where+ sqlType _ = sqlType (Proxy :: Proxy Int)++share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "typeLitFieldDefsMigrate"] [persistLowerCase|+ TypeLitFieldDefsNumeric+ one (Finite 1)+ twenty (Finite 20)+ deriving Eq Show++ TypeLitFieldDefsLabelled+ one (Labelled "one")+ twenty (Labelled "twenty")+ deriving Eq Show+|]++one :: Finite 1+one = Finite 1++oneLabelled :: Labelled "one"+oneLabelled = Labelled 1++twenty :: Finite 20+twenty = Finite 20++twentyLabelled :: Labelled "twenty"+twentyLabelled = Labelled 20++specsWith :: Runner backend m => RunDb backend m -> Spec+specsWith runDb =+ describe "Type Lit Field Definitions" $ do+ it "runs appropriate migrations" $ runDb $ do+ numKey <- insert $ TypeLitFieldDefsNumeric one twenty+ num <- getJust numKey+ liftIO $ typeLitFieldDefsNumericOne num @?= one+ liftIO $ typeLitFieldDefsNumericTwenty num @?= twenty++ labelledKey <- insert $ TypeLitFieldDefsLabelled oneLabelled twentyLabelled+ lbl <- getJust labelledKey+ liftIO $ typeLitFieldDefsLabelledOne lbl @?= oneLabelled+ liftIO $ typeLitFieldDefsLabelledTwenty lbl @?= twentyLabelled