diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ ## Unreleased changes +## 2.0.3.4 + +* lots of stuff actually :\ should probably start tracking this more! + ## 2.0.3.3 * Fix RawSqlTest, which could fail non-deterministically for Postgres [#1139](https://github.com/yesodweb/persistent/pull/1139) 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.0.3.3 +version: 2.0.3.4 license: MIT license-file: LICENSE author: Michael Snoyman @@ -39,6 +39,7 @@ PersistentTest PersistentTestModels PersistentTestModelsImports + GeneratedColumnTestSQL PersistTestPetType PersistTestPetCollarType PersistUniqueTest @@ -97,6 +98,7 @@ StandaloneDeriving DerivingStrategies GeneralizedNewtypeDeriving + DataKinds source-repository head type: git diff --git a/src/CompositeTest.hs b/src/CompositeTest.hs --- a/src/CompositeTest.hs +++ b/src/CompositeTest.hs @@ -135,7 +135,7 @@ it "Extract Parent Foreign Key from Child value" $ runDb $ do kp1 <- insert p1 - _ <- insert p2 + insert_ p2 kc1 <- insert c1 mc <- get kc1 isJust mc @== True @@ -144,9 +144,9 @@ testChildFkparent c11 @== kp1 it "Validate Key contents" $ runDb $ do - _ <- insert p1 - _ <- insert p2 - _ <- insert p3 + insert_ p1 + insert_ p2 + insert_ p3 xs <- selectKeysList [] [Asc TestParentName] length xs @== 3 let [kps1,kps2,kps3] = xs @@ -178,7 +178,7 @@ it "Replace Child" $ runDb $ do -- c1 FKs p1 - _ <- insert p1 + insert_ p1 kc1 <- insert c1 _ <- replace kc1 c1' newc1 <- get kc1 diff --git a/src/ForeignKey.hs b/src/ForeignKey.hs --- a/src/ForeignKey.hs +++ b/src/ForeignKey.hs @@ -1,66 +1,230 @@ {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables, TypeApplications, UndecidableInstances #-} + module ForeignKey where +import Data.Proxy +import qualified Data.List as List 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"] [persistLowerCase| - Parent - name String +SimpleCascadeChild + ref SimpleCascadeId OnDeleteCascade + deriving Show Eq + +SimpleCascade + name Int + deriving Show Eq + +Parent + name Int Primary name - Child - pname String +Child + pname Int Foreign Parent OnDeleteCascade OnUpdateCascade fkparent pname deriving Show Eq - ParentComposite - name String - lastName String +ParentImplicit + name Int + +ChildImplicit + pname Int + parentId ParentImplicitId noreference + Foreign ParentImplicit OnDeleteCascade OnUpdateCascade fkparent parentId + deriving Show Eq + +ParentComposite + name Int + lastName Int Primary name lastName - ChildComposite - pname String - plastName String +ChildComposite + pname Int + plastName Int Foreign ParentComposite OnDeleteCascade fkparent pname plastName deriving Show Eq - SelfReferenced - name String - pname String +SelfReferenced + name Int + pname Int Primary name Foreign SelfReferenced OnDeleteCascade fkparent pname deriving Show Eq + +A + aa Int + ab Int + U1 aa + +B + ba Int + bb Int + Foreign A OnDeleteCascade fkA ba References aa + deriving Show Eq + +AComposite + aa Int + ab Int + U2 aa ab + +BComposite + ba Int + bb Int + Foreign AComposite OnDeleteCascade fkAComposite ba bb References aa ab + deriving Show Eq + +BExplicit + ba AId noreference + Foreign A OnDeleteCascade fkAI ba References Id + deriving Show Eq + +Chain + name Int + previous ChainId Maybe noreference + Foreign Chain OnDeleteSetNull fkChain previous References Id + deriving Show Eq Ord + +Chain2 + name Int + previous Chain2Id Maybe noreference + Foreign Chain2 OnDeleteCascade fkChain previous References Id + deriving Show Eq |] specsWith :: (MonadIO m, MonadFail m) => RunDb SqlBackend m -> Spec specsWith runDb = describe "foreign keys options" $ do - it "delete cascades" $ runDb $ do - kf <- insert $ Parent "A" - kc <- insert $ Child "A" - delete kf - cs <- selectList [] [] - let expected = [] :: [Entity Child] - cs @== expected - it "update cascades" $ runDb $ do - kf <- insert $ Parent "A" - kc <- insert $ Child "A" - update kf [ParentName =. "B"] - cs <- selectList [] [] - fmap (childPname . entityVal) cs @== ["B"] - it "delete Composite cascades" $ runDb $ do - kf <- insert $ ParentComposite "A" "B" - kc <- insert $ ChildComposite "A" "B" - delete kf - cs <- selectList [] [] - let expected = [] :: [Entity ChildComposite] - cs @== expected - it "delete self referenced cascades" $ runDb $ do - kf <- insert $ SelfReferenced "A" "A" -- bootstrap self reference - kc <- insert $ SelfReferenced "B" "A" - delete kf - srs <- selectList [] [] - let expected = [] :: [Entity SelfReferenced] - srs @== expected + it "delete cascades" $ runDb $ do + kf <- insert $ Parent 1 + insert_ $ Child 1 + delete kf + cs <- selectList [] [] + let expected = [] :: [Entity Child] + cs @== expected + it "update cascades" $ runDb $ do + kf <- insert $ Parent 1 + insert_ $ Child 1 + update kf [ParentName =. 2] + cs <- selectList [] [] + fmap (childPname . entityVal) cs @== [2] + it "delete Composite cascades" $ runDb $ do + kf <- insert $ ParentComposite 1 2 + insert_ $ ChildComposite 1 2 + delete kf + cs <- selectList [] [] + let expected = [] :: [Entity ChildComposite] + cs @== expected + it "delete self referenced cascades" $ runDb $ do + kf <- insert $ SelfReferenced 1 1 + insert_ $ SelfReferenced 2 1 + delete kf + srs <- selectList [] [] + let expected = [] :: [Entity SelfReferenced] + srs @== expected + it "delete cascade works on simple references" $ runDb $ do + scId <- insert $ SimpleCascade 1 + sccId <- insert $ SimpleCascadeChild scId + Just _ <- get sccId + delete scId + mres <- get sccId + mxs <- selectList @SimpleCascadeChild [] [] + liftIO $ do + mres `shouldBe` Nothing + mxs `shouldBe` [] + it "delete cascades with explicit Reference" $ runDb $ do + kf <- insert $ A 1 40 + insert_ $ B 1 15 + delete kf + return () + cs <- selectList [] [] + let expected = [] :: [Entity B] + cs @== expected + it "delete cascades with explicit Composite Reference" $ runDb $ do + kf <- insert $ AComposite 1 20 + insert_ $ BComposite 1 20 + delete kf + return () + cs <- selectList [] [] + let expected = [] :: [Entity B] + cs @== expected + it "delete cascades with explicit Composite Reference" $ runDb $ do + kf <- insert $ AComposite 1 20 + insert_ $ BComposite 1 20 + delete kf + return () + cs <- selectList [] [] + let expected = [] :: [Entity B] + cs @== expected + it "delete cascades with explicit Id field" $ runDb $ do + kf <- insert $ A 1 20 + insert_ $ BExplicit kf + delete kf + return () + cs <- selectList [] [] + let expected = [] :: [Entity B] + cs @== expected + it "deletes sets null with self reference" $ runDb $ do + kf <- insert $ Chain 1 Nothing + kf' <- insert $ Chain 2 (Just kf) + delete kf + cs <- selectList [] [] + let expected = [Entity {entityKey = kf', entityVal = Chain 2 Nothing}] + List.sort cs @== List.sort expected + it "deletes cascades with self reference to the whole chain" $ runDb $ do + k1 <- insert $ Chain2 1 Nothing + k2 <- insert $ Chain2 2 (Just k1) + insert_ $ Chain2 3 (Just k2) + delete k1 + cs <- selectList [] [] + let expected = [] :: [Entity Chain2] + cs @== expected + + describe "EntityDef" $ do + let ed = + entityDef (Proxy @SimpleCascadeChild) + isRefCol = + (HaskellName "ref" ==) . fieldHaskell + expected = FieldCascade + { fcOnUpdate = Nothing + , fcOnDelete = Just Cascade + } + Just refField = + List.find isRefCol (entityFields ed) + + it "parses into fieldCascade" $ do + fieldCascade refField `shouldBe` expected + + it "shouldn't have cascade in extras" $ do + entityExtra ed + `shouldBe` + mempty + +cleanDB :: (MonadIO m) => SqlPersistT m () +cleanDB = do + del @SimpleCascadeChild + del @SimpleCascade + del @Parent + del @ParentComposite + del @ParentImplicit + del @Child + del @ChildComposite + del @ChildImplicit + del @SelfReferenced + del @A + del @AComposite + del @B + del @BExplicit + del @BComposite + del @Chain + del @Chain2 + +del + :: forall a m. + ( PersistEntity a + , PersistEntityBackend a ~ SqlBackend + , MonadIO m + ) + => SqlPersistT m () +del = deleteWhere @_ @_ @a [] diff --git a/src/GeneratedColumnTestSQL.hs b/src/GeneratedColumnTestSQL.hs new file mode 100644 --- /dev/null +++ b/src/GeneratedColumnTestSQL.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} +module GeneratedColumnTestSQL (specsWith) where + +import Database.Persist.TH +import Init + +share [mkPersist sqlSettings, mkMigrate "migrate1", mkDeleteCascade sqlSettings] [persistLowerCase| +GenTest sql=gen_test + fieldOne Text Maybe + fieldTwo Text Maybe + fieldThree Text Maybe generated=COALESCE(field_one,field_two) + deriving Show Eq + +MigrateTestV1 sql=gen_migrate_test + sickness Int + cromulence Int generated=5 +|] + +share [mkPersist sqlSettings, mkMigrate "migrate2", mkDeleteCascade sqlSettings] [persistLowerCase| +MigrateTestV2 sql=gen_migrate_test + sickness Int generated=3 + cromulence Int +|] + +specsWith :: Runner SqlBackend m => RunDb SqlBackend m -> Spec +specsWith runDB = describe "PersistLiteral field" $ do + it "should read a generated column" $ runDB $ do + rawExecute "DROP TABLE IF EXISTS gen_test;" [] + rawExecute "DROP TABLE IF EXISTS gen_migrate_test;" [] + runMigration migrate1 + + insert_ GenTest + { genTestFieldOne = Just "like, literally this exact string" + , genTestFieldTwo = Just "like, totally some other string" + , genTestFieldThree = Nothing + } + Just (Entity _ GenTest{..}) <- selectFirst [] [] + liftIO $ genTestFieldThree @?= Just "like, literally this exact string" + + k1 <- insert $ MigrateTestV1 0 0 + Just (MigrateTestV1 sickness1 cromulence1) <- get k1 + liftIO $ sickness1 @?= 0 + liftIO $ cromulence1 @?= 5 + + it "should support adding or removing generation expressions from columns" $ runDB $ do + runMigration migrate2 + + k2 <- insert $ MigrateTestV2 0 0 + Just (MigrateTestV2 sickness2 cromulence2) <- get k2 + liftIO $ sickness2 @?= 3 + liftIO $ cromulence2 @?= 0 diff --git a/src/HtmlTest.hs b/src/HtmlTest.hs --- a/src/HtmlTest.hs +++ b/src/HtmlTest.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DataKinds, UndecidableInstances #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-} module HtmlTest (specsWith, cleanDB, htmlMigrate) where diff --git a/src/Init.hs b/src/Init.hs --- a/src/Init.hs +++ b/src/Init.hs @@ -41,21 +41,28 @@ , arbText , liftA2 , changeBackend + , Proxy(..) ) 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 Control.Monad.IO.Class +import Control.Monad.Logger +import qualified Control.Monad.Fail as MonadFail +#endif + -- needed for backwards compatibility import Control.Monad.Base import Control.Monad.Catch import Control.Monad.IO.Unlift -import qualified Control.Monad.Fail as MonadFail -import Control.Monad.Logger import Control.Monad.Trans.Class import Control.Monad.Trans.Control import Control.Monad.Trans.Resource import Control.Monad.Trans.Resource.Internal -- re-exports -import Control.Applicative (liftA2) +import Control.Applicative (liftA2, (<|>)) import Control.Exception (SomeException) import Control.Monad (void, replicateM, liftM, when, forM_) import Control.Monad.Fail (MonadFail) @@ -66,6 +73,7 @@ import Data.Time import Test.Hspec import Test.QuickCheck.Instances () +import Data.Proxy import Database.Persist.TH (mkPersist, mkMigrate, share, sqlSettings, persistLowerCase, persistUpperCase, MkPersistSettings(..)) @@ -74,7 +82,6 @@ import Test.QuickCheck import Control.Monad (unless, (>=>)) -import Control.Monad.IO.Class import Control.Monad.IO.Unlift (MonadUnliftIO) import qualified Data.ByteString as BS import Data.IORef @@ -119,11 +126,15 @@ assertNotEmpty xs = liftIO $ assertBool "" (not (null xs)) isTravis :: IO Bool -isTravis = do - env <- liftIO getEnvironment - return $ case lookup "TRAVIS" env of - Just "true" -> True - _ -> False +isTravis = isCI + +isCI :: IO Bool +isCI = do + env <- liftIO getEnvironment + return $ case lookup "TRAVIS" env <|> lookup "CI" env of + Just "true" -> True + _ -> False + persistSettings :: MkPersistSettings persistSettings = sqlSettings { mpsGeneric = True } diff --git a/src/MigrationTest.hs b/src/MigrationTest.hs --- a/src/MigrationTest.hs +++ b/src/MigrationTest.hs @@ -42,14 +42,14 @@ again <- getMigration migrationMigrate liftIO $ again @?= [] it "really is idempotent" $ runDb $ do - runMigrationSilent migrationMigrate - runMigrationSilent migrationMigrate + void $ runMigrationSilent migrationMigrate + void $ runMigrationSilent migrationMigrate again <- getMigration migrationMigrate liftIO $ again @?= [] it "can add an extra column" $ runDb $ do -- Failing test case for #735. Foreign-key checking, switched on in -- version 2.6.1, caused persistent-sqlite to generate a `references` -- constraint in a *temporary* table during migration, which fails. - _ <- runMigrationSilent migrationAddCol + void $ runMigrationSilent migrationAddCol again <- getMigration migrationAddCol liftIO $ again @?= [] diff --git a/src/PersistUniqueTest.hs b/src/PersistUniqueTest.hs --- a/src/PersistUniqueTest.hs +++ b/src/PersistUniqueTest.hs @@ -31,3 +31,18 @@ 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 + + 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'' + Just (UniqueBar conflict) <- checkUniqueUpdateable $ Entity k fo'' -- fo can't be updated to fo'' + conflict @== b + 1 diff --git a/src/PersistentTest.hs b/src/PersistentTest.hs --- a/src/PersistentTest.hs +++ b/src/PersistentTest.hs @@ -14,7 +14,6 @@ import Control.Monad.IO.Class import Data.Aeson import Data.Conduit -import qualified Data.Text as T import qualified Data.Conduit.List as CL import Data.Functor.Constant import Data.Functor.Identity @@ -28,7 +27,6 @@ import Data.Proxy (Proxy(..)) import Database.Persist -import Database.Persist.Quasi import Init import PersistentTestModels import PersistTestPetType @@ -48,12 +46,12 @@ filterOrSpecs runDb = describe "FilterOr" $ do it "FilterOr []" $ runDb $ do let p = Person "z" 1 Nothing - _ <- insert p + insert_ p ps <- selectList [FilterOr []] [Desc PersonAge] assertEmpty ps it "||. []" $ runDb $ do let p = Person "z" 1 Nothing - _ <- insert p + insert_ p c <- count $ [PersonName ==. "a"] ||. [] c @== (1::Int) @@ -62,7 +60,7 @@ _polymorphic = do ((Entity id' _):_) <- selectList [] [LimitTo 1] _ <- selectList [PetOwnerId ==. id'] [] - _ <- insert $ Pet id' "foo" Cat + insert_ $ Pet id' "foo" Cat return () -- Some lens stuff @@ -86,7 +84,7 @@ it "FilterAnd []" $ runDb $ do let p = Person "z" 1 Nothing - _ <- insert p + insert_ p ps <- selectList [FilterAnd []] [Desc PersonAge] assertNotEmpty ps @@ -139,13 +137,21 @@ Just mic29 <- get micK personAge mic29 @== 29 + let louis = Person "Louis" 55 $ Just "brown" + ex0 <- exists [PersonName ==. "Louis"] + ex0 @== False + louisK <- insert louis + ex1 <- exists [PersonName ==. "Louis"] + ex1 @== True + delete louisK + let eli = Person "Eliezer" 2 $ Just "blue" - _ <- insert eli + insert_ eli pasc <- selectList [] [Asc PersonAge] map entityVal pasc @== [eli, mic29] let abe30 = Person "Abe" 30 $ Just "black" - _ <- insert abe30 + insert_ abe30 -- pdesc <- selectList [PersonAge <. 30] [Desc PersonName] map entityVal pasc @== [eli, mic29] @@ -179,9 +185,9 @@ it "!=." $ runDb $ do deleteWhere ([] :: [Filter (PersonGeneric backend)]) let mic = Person "Michael" 25 Nothing - _ <- insert mic + insert_ mic let eli = Person "Eliezer" 25 (Just "Red") - _ <- insert eli + insert_ eli pne <- selectList [PersonName !=. "Michael"] [] map entityVal pne @== [eli] @@ -196,9 +202,9 @@ it "Double Maybe" $ runDb $ do deleteWhere ([] :: [Filter (PersonMayGeneric backend)]) let mic = PersonMay (Just "Michael") Nothing - _ <- insert mic + insert_ mic let eli = PersonMay (Just "Eliezer") (Just "Red") - _ <- insert eli + insert_ eli pe <- selectList [PersonMayName ==. Nothing, PersonMayColor ==. Nothing] [] map entityVal pe @== [] pne <- selectList [PersonMayName !=. Nothing, PersonMayColor !=. Nothing] [] @@ -258,7 +264,7 @@ it "deleteBy" $ runDb $ do - _ <- insert $ Person "Michael2" 27 Nothing + insert_ $ Person "Michael2" 27 Nothing let p3 = Person "Michael3" 27 Nothing key3 <- insert p3 @@ -437,7 +443,7 @@ e4 @== Nothing it "selectFirst" $ runDb $ do - _ <- insert $ Person "Michael" 26 Nothing + insert_ $ Person "Michael" 26 Nothing let pOld = Person "Oldie" 75 Nothing kOld <- insert pOld @@ -577,7 +583,7 @@ p2 = Person "E" 1 Nothing p3 = Person "F" 2 Nothing pid1 <- insert p1 - _ <- insert p2 + insert_ p2 pid3 <- insert p3 x <- selectList [PersonId <-. [pid1, pid3]] [] liftIO $ x @?= [Entity pid1 p1, Entity pid3 p3] @@ -630,7 +636,7 @@ `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, parentField] = entityFields edef + let [nameField, _] = entityFields edef fieldComments nameField `shouldBe` Just "Fields should be documentable.\n" @@ -653,11 +659,11 @@ it "decodes without an ID field" $ do let - json = encode . Object . M.fromList $ + json_ = encode . Object . M.fromList $ [ ("name", String "Bob") , ("age", toJSON (32 :: Int)) ] - decode json + decode json_ `shouldBe` Just subjectEntity @@ -703,5 +709,3 @@ , ("blood", toJSON jsonEncoding2Blood) , ("id", toJSON key) ]) - - diff --git a/src/RawSqlTest.hs b/src/RawSqlTest.hs --- a/src/RawSqlTest.hs +++ b/src/RawSqlTest.hs @@ -36,16 +36,16 @@ Entity _ _ <- insertEntity $ Pet p3k "Abacate" Cat escape <- getEscape person <- getTableName (error "rawSql Person" :: Person) - name <- getFieldName PersonName + name_ <- getFieldName PersonName pet <- getTableName (error "rawSql Pet" :: Pet) - petName <- getFieldName PetName + petName_ <- getFieldName PetName let query = T.concat [ "SELECT ??, ?? " , "FROM ", person , ", ", escape "Pet" , " WHERE ", person, ".", escape "age", " >= ? " , "AND ", escape "Pet", ".", escape "ownerId", " = " , person, ".", escape "id" - , " ORDER BY ", person, ".", name, ", ", pet, ".", petName + , " ORDER BY ", person, ".", name_, ", ", pet, ".", petName_ ] ret <- rawSql query [PersistInt64 20] liftIO $ ret @?= [ (Entity p1k p1, Entity a1k a1) @@ -150,9 +150,9 @@ let p = Person1 "foo" 0 - _ <- insert p - _ <- insert p - _ <- insert p + insert_ p + insert_ p + insert_ p c1 <- count filt c1 @== 3 @@ -161,15 +161,15 @@ c2 <- count filt c2 @== 3 - _ <- insert p + insert_ p transactionUndo c3 <- count filt c3 @== 3 - _ <- insert p + insert_ p transactionSave - _ <- insert p - _ <- insert p + insert_ p + insert_ p transactionUndo c4 <- count filt c4 @== 4 diff --git a/src/ReadWriteTest.hs b/src/ReadWriteTest.hs --- a/src/ReadWriteTest.hs +++ b/src/ReadWriteTest.hs @@ -46,10 +46,10 @@ it "type checks on PersistUniqueWrite/Read functions" $ do runDb $ do - let name = "Matt Parsons New" - person = Person name 30 Nothing + let name_ = "Matt Parsons New" + person = Person name_ 30 Nothing _mkey0 <- insertUnique person mkey1 <- insertUnique person mkey1 @== Nothing - mperson <- selectFirst [PersonName ==. name] [] + mperson <- selectFirst [PersonName ==. name_] [] fmap entityVal mperson @== Just person diff --git a/src/RenameTest.hs b/src/RenameTest.hs --- a/src/RenameTest.hs +++ b/src/RenameTest.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeApplications, UndecidableInstances #-} + module RenameTest where import qualified Data.Map as Map @@ -72,17 +73,23 @@ => RunDb backend m -> Spec specsWith runDb = describe "rename specs" $ do + describe "LowerCaseTable" $ do + it "LowerCaseTable has the right sql name" $ do + fieldDB (entityId (entityDef (Proxy @LowerCaseTable))) + `shouldBe` + DBName "my_id" + it "user specified id, insertKey, no default=" $ runDb $ do - let rec2 = IdTable "Foo2" Nothing - let rec1 = IdTable "Foo1" $ Just rec2 - let rec = IdTable "Foo" $ Just rec1 - now <- liftIO getCurrentTime - let key = IdTableKey $ utctDay now - insertKey key rec - Just rec' <- get key - rec' @== rec - (Entity key' _):_ <- selectList ([] :: [Filter (IdTableGeneric backend)]) [] - key' @== key + let rec2 = IdTable "Foo2" Nothing + let rec1 = IdTable "Foo1" $ Just rec2 + let rec = IdTable "Foo" $ Just rec1 + now <- liftIO getCurrentTime + let key = IdTableKey $ utctDay now + insertKey key rec + Just rec' <- get key + rec' @== rec + (Entity key' _):_ <- selectList ([] :: [Filter (IdTableGeneric backend)]) [] + key' @== key it "extra blocks" $ entityExtra (entityDef (Nothing :: Maybe LowerCaseTable)) @?= diff --git a/src/TransactionLevelTest.hs b/src/TransactionLevelTest.hs --- a/src/TransactionLevelTest.hs +++ b/src/TransactionLevelTest.hs @@ -22,6 +22,6 @@ it (show il ++ " works") $ runDb $ do transactionUndoWithIsolation il deleteWhere ([] :: [Filter Wombat]) - _ <- insert item + insert_ item Just item' <- get (WombatKey "uno") item' @== item diff --git a/src/TreeTest.hs b/src/TreeTest.hs --- a/src/TreeTest.hs +++ b/src/TreeTest.hs @@ -6,7 +6,6 @@ import Init import Database.Persist.TH (mkDeleteCascade) -import Data.Proxy -- mpsGeneric = False is due to a bug or at least lack of a feature in diff --git a/src/UpsertTest.hs b/src/UpsertTest.hs --- a/src/UpsertTest.hs +++ b/src/UpsertTest.hs @@ -148,7 +148,7 @@ describe "putMany" $ do it "adds new rows when entity has no unique constraints" $ runDb $ do - let mkPerson name = Person1 name 25 + let mkPerson name_ = Person1 name_ 25 let names = ["putMany bob", "putMany bob", "putMany smith"] let records = map mkPerson names _ <- putMany records