diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ ## Unreleased changes +# 2.13.2.1 +* [#1610](https://github.com/yesodweb/persistent/pull/1610) + * Added `NoAction` as a `CascadeAction` + # 2.13.2.0 * [#1601](https://github.com/yesodweb/persistent/pull/1601) * Adjust test data to avoid deprecated entity definition syntax 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.13.2.0 +version: 2.13.2.1 license: MIT license-file: LICENSE author: Michael Snoyman @@ -77,7 +77,7 @@ , monad-logger >=0.3.25 , mtl , path-pieces >=0.2 - , persistent >=2.16 && <2.18 + , persistent >=2.16 && <2.19 , 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 @@ -1,8 +1,10 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -- FIXME +-- FIXME +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + module CompositeTest where import qualified Data.Map as Map @@ -10,9 +12,10 @@ 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| +share + [mkPersist persistSettings{mpsGeneric = False}, mkMigrate "compositeMigrate"] + [persistLowerCase| TestParent name String maxlen=20 name2 String maxlen=20 @@ -50,193 +53,215 @@ deriving Eq Show |] -cleanDB :: (PersistQuery backend, PersistEntityBackend TestChild ~ backend, MonadIO m) => ReaderT backend m () +cleanDB + :: (PersistQuery backend, PersistEntityBackend TestChild ~ backend, MonadIO m) + => ReaderT backend m () cleanDB = do - deleteWhere ([] :: [Filter TestChild]) - deleteWhere ([] :: [Filter TestParent]) - deleteWhere ([] :: [Filter CitizenAddress]) - deleteWhere ([] :: [Filter Citizen]) - deleteWhere ([] :: [Filter Address]) + deleteWhere ([] :: [Filter TestChild]) + deleteWhere ([] :: [Filter TestParent]) + deleteWhere ([] :: [Filter CitizenAddress]) + deleteWhere ([] :: [Filter Citizen]) + deleteWhere ([] :: [Filter Address]) specsWith :: (MonadIO m, MonadFail m) => RunDb SqlBackend m -> Spec specsWith runDb = describe "composite" $ - describe "primary keys" $ do - - let p1 = TestParent "a1" "b1" 11 "p1" - let p2 = TestParent "a2" "b2" 22 "p2" - let p3 = TestParent "a3" "b3" 33 "p3" - let p1' = TestParent "a1" "b1" 11 "p1'" - let c1 = TestChild "a1" "b1" 11 "c1" - let c1' = TestChild "a1" "b1" 11 "c1'" + describe "primary keys" $ do + let + p1 = TestParent "a1" "b1" 11 "p1" + let + p2 = TestParent "a2" "b2" 22 "p2" + let + p3 = TestParent "a3" "b3" 33 "p3" + let + p1' = TestParent "a1" "b1" 11 "p1'" + let + c1 = TestChild "a1" "b1" 11 "c1" + let + c1' = TestChild "a1" "b1" 11 "c1'" - it "insertWithKey" $ runDb $ do - kp1 <- insert p1 - delete kp1 - insertKey kp1 p2 + it "insertWithKey" $ runDb $ do + kp1 <- insert p1 + delete kp1 + insertKey kp1 p2 - it "repsert" $ runDb $ do - kp1 <- insert p1 - repsert kp1 p2 + it "repsert" $ runDb $ do + kp1 <- insert p1 + repsert kp1 p2 - it "Insert" $ runDb $ do - kp1 <- insert p1 - matchParentK kp1 @== Right ("a1","b1",11) - mp <- get kp1 - isJust mp @== True - let Just p11 = mp - p1 @== p11 - xs <- selectList [TestParentId ==. kp1] [] - length xs @== 1 - let [Entity newkp1 newp1] = xs - matchParentK kp1 @== matchParentK newkp1 - p1 @== newp1 + it "Insert" $ runDb $ do + kp1 <- insert p1 + matchParentK kp1 @== Right ("a1", "b1", 11) + mp <- get kp1 + isJust mp @== True + let + Just p11 = mp + p1 @== p11 + xs <- selectList [TestParentId ==. kp1] [] + length xs @== 1 + let + [Entity newkp1 newp1] = xs + matchParentK kp1 @== matchParentK newkp1 + p1 @== newp1 - it "Id field" $ runDb $ do - kp1 <- insert p1 - kp2 <- insert p2 - xs <- selectList [TestParentId <-. [kp1,kp2]] [] - length xs @== 2 - [(Entity newkp1 newp1),(Entity newkp2 newp2)] <- pure xs - matchParentK kp1 @== matchParentK newkp1 - matchParentK kp2 @== matchParentK newkp2 - p1 @== newp1 - p2 @== newp2 + it "Id field" $ runDb $ do + kp1 <- insert p1 + kp2 <- insert p2 + xs <- selectList [TestParentId <-. [kp1, kp2]] [] + length xs @== 2 + [(Entity newkp1 newp1), (Entity newkp2 newp2)] <- pure xs + matchParentK kp1 @== matchParentK newkp1 + matchParentK kp2 @== matchParentK newkp2 + p1 @== newp1 + p2 @== newp2 - it "Filter by Id with 'not equal'" $ runDb $ do - kp1 <- insert p1 - kp2 <- insert p2 - xs <- selectList [TestParentId !=. kp1] [] - length xs @== 1 - let [Entity newkp2 _newp2] = xs - matchParentK kp2 @== matchParentK newkp2 + it "Filter by Id with 'not equal'" $ runDb $ do + kp1 <- insert p1 + kp2 <- insert p2 + xs <- selectList [TestParentId !=. kp1] [] + length xs @== 1 + let + [Entity newkp2 _newp2] = xs + matchParentK kp2 @== matchParentK newkp2 - it "Filter by Id with 'in'" $ runDb $ do - kp1 <- insert p1 - kp2 <- insert p2 - xs <- selectList [TestParentId <-. [kp1,kp2]] [] - length xs @== 2 - let [Entity newkp1 _newp1,Entity newkp2 _newp2] = xs - matchParentK kp1 @== matchParentK newkp1 - matchParentK kp2 @== matchParentK newkp2 + it "Filter by Id with 'in'" $ runDb $ do + kp1 <- insert p1 + kp2 <- insert p2 + xs <- selectList [TestParentId <-. [kp1, kp2]] [] + length xs @== 2 + let + [Entity newkp1 _newp1, Entity newkp2 _newp2] = xs + matchParentK kp1 @== matchParentK newkp1 + matchParentK kp2 @== matchParentK newkp2 - it "Filter by Id with 'not in'" $ runDb $ do - kp1 <- insert p1 - kp2 <- insert p2 - xs <- selectList [TestParentId /<-. [kp1]] [] - length xs @== 1 - let [Entity newkp2 _newp2] = xs - matchParentK kp2 @== matchParentK newkp2 + it "Filter by Id with 'not in'" $ runDb $ do + kp1 <- insert p1 + kp2 <- insert p2 + xs <- selectList [TestParentId /<-. [kp1]] [] + length xs @== 1 + let + [Entity newkp2 _newp2] = xs + matchParentK kp2 @== matchParentK newkp2 - it "Filter by Id with 'not in' with no data" $ runDb $ do - kp1 <- insert p1 - kp2 <- insert p2 - xs <- selectList [TestParentId /<-. [kp1,kp2]] [] - length xs @== 0 + it "Filter by Id with 'not in' with no data" $ runDb $ do + kp1 <- insert p1 + kp2 <- insert p2 + xs <- selectList [TestParentId /<-. [kp1, kp2]] [] + length xs @== 0 - it "Extract Parent Foreign Key from Child value" $ runDb $ do - kp1 <- insert p1 - insert_ p2 - kc1 <- insert c1 - mc <- get kc1 - isJust mc @== True - let Just c11 = mc - c1 @== c11 - testChildFkparent c11 @== kp1 + it "Extract Parent Foreign Key from Child value" $ runDb $ do + kp1 <- insert p1 + insert_ p2 + kc1 <- insert c1 + mc <- get kc1 + isJust mc @== True + let + Just c11 = mc + c1 @== c11 + testChildFkparent c11 @== kp1 - it "Validate Key contents" $ runDb $ do - insert_ p1 - insert_ p2 - insert_ p3 - xs <- selectKeysList [] [Asc TestParentName] - length xs @== 3 - let [kps1,kps2,kps3] = xs - matchParentK kps1 @== Right ("a1","b1",11) - matchParentK kps2 @== Right ("a2","b2",22) - matchParentK kps3 @== Right ("a3","b3",33) + it "Validate Key contents" $ runDb $ do + insert_ p1 + insert_ p2 + insert_ p3 + xs <- selectKeysList [] [Asc TestParentName] + length xs @== 3 + let + [kps1, kps2, kps3] = xs + matchParentK kps1 @== Right ("a1", "b1", 11) + matchParentK kps2 @== Right ("a2", "b2", 22) + matchParentK kps3 @== Right ("a3", "b3", 33) - it "Delete" $ runDb $ do - kp1 <- insert p1 - kp2 <- insert p2 + it "Delete" $ runDb $ do + kp1 <- insert p1 + kp2 <- insert p2 - _ <- delete kp1 - r <- get kp1 - r @== Nothing - r1 <- get kp2 - isJust r1 @== True + _ <- delete kp1 + r <- get kp1 + r @== Nothing + r1 <- get kp2 + isJust r1 @== True - it "Update" $ runDb $ do - kp1 <- insert p1 - _ <- update kp1 [TestParentExtra44 =. "q1"] - newkps1 <- get kp1 - newkps1 @== Just (TestParent "a1" "b1" 11 "q1") + it "Update" $ runDb $ do + kp1 <- insert p1 + _ <- update kp1 [TestParentExtra44 =. "q1"] + newkps1 <- get kp1 + newkps1 @== Just (TestParent "a1" "b1" 11 "q1") - it "Replace Parent" $ runDb $ do - kp1 <- insert p1 - _ <- replace kp1 p1' - newp1 <- get kp1 - newp1 @== Just p1' + it "Replace Parent" $ runDb $ do + kp1 <- insert p1 + _ <- replace kp1 p1' + newp1 <- get kp1 + newp1 @== Just p1' - it "Replace Child" $ runDb $ do - -- c1 FKs p1 - insert_ p1 - kc1 <- insert c1 - _ <- replace kc1 c1' - newc1 <- get kc1 - newc1 @== Just c1' + it "Replace Child" $ runDb $ do + -- c1 FKs p1 + insert_ p1 + kc1 <- insert c1 + _ <- replace kc1 c1' + newc1 <- get kc1 + newc1 @== Just c1' - it "Insert Many to Many" $ runDb $ do - let z1 = Citizen "mk" (Just 11) - let a1 = Address "abc" "usa" - let z2 = Citizen "gb" (Just 22) - let a2 = Address "def" "den" + it "Insert Many to Many" $ runDb $ do + let + z1 = Citizen "mk" (Just 11) + let + a1 = Address "abc" "usa" + let + z2 = Citizen "gb" (Just 22) + let + a2 = Address "def" "den" - kc1 <- insert z1 - ka1 <- insert a1 - let ca1 = CitizenAddress kc1 ka1 - kca1 <- insert ca1 - matchCitizenAddressK kca1 @== matchK2 kc1 ka1 + kc1 <- insert z1 + ka1 <- insert a1 + let + ca1 = CitizenAddress kc1 ka1 + kca1 <- insert ca1 + matchCitizenAddressK kca1 @== matchK2 kc1 ka1 - mca <- get kca1 - isJust mca @== True - let Just newca1 = mca - ca1 @== newca1 + mca <- get kca1 + isJust mca @== True + let + Just newca1 = mca + ca1 @== newca1 - kc2 <- insert z2 - ka2 <- insert a2 - let ca2 = CitizenAddress kc2 ka2 - kca2 <- insert ca2 - matchCitizenAddressK kca2 @== matchK2 kc2 ka2 + kc2 <- insert z2 + ka2 <- insert a2 + let + ca2 = CitizenAddress kc2 ka2 + kca2 <- insert ca2 + matchCitizenAddressK kca2 @== matchK2 kc2 ka2 - xs <- selectList [CitizenAddressId ==. kca1] [] - length xs @== 1 - let [Entity newkca1 newca2] = xs - matchCitizenAddressK kca1 @== matchCitizenAddressK newkca1 - ca1 @== newca2 - it "insertMany" $ runDb $ do - [kp1, kp2] <- insertMany [p1, p2] - rs <- getMany [kp1, kp2] - rs @== Map.fromList [(kp1, p1), (kp2, p2)] - it "RawSql Key instance" $ runDb $ do - key <- insert p1 - keyFromRaw <- rawSql "SELECT name, name2, age FROM test_parent LIMIT 1" [] - [key] @== keyFromRaw + xs <- selectList [CitizenAddressId ==. kca1] [] + length xs @== 1 + let + [Entity newkca1 newca2] = xs + matchCitizenAddressK kca1 @== matchCitizenAddressK newkca1 + ca1 @== newca2 + it "insertMany" $ runDb $ do + [kp1, kp2] <- insertMany [p1, p2] + rs <- getMany [kp1, kp2] + rs @== Map.fromList [(kp1, p1), (kp2, p2)] + it "RawSql Key instance" $ runDb $ do + key <- insert p1 + keyFromRaw <- rawSql "SELECT name, name2, age FROM test_parent LIMIT 1" [] + [key] @== keyFromRaw --- TODO: push into persistent-qq test suite --- it "RawSql Key instance with sqlQQ" $ runDb $ do --- key <- insert p1 --- keyFromRaw' <- [sqlQQ| --- SELECT @{TestParentName}, @{TestParentName2}, @{TestParentAge} --- FROM ^{TestParent} --- LIMIT 1 --- |] --- [key] @== keyFromRaw' + -- TODO: push into persistent-qq test suite + -- it "RawSql Key instance with sqlQQ" $ runDb $ do + -- key <- insert p1 + -- keyFromRaw' <- [sqlQQ| + -- SELECT @{TestParentName}, @{TestParentName2}, @{TestParentAge} + -- FROM ^{TestParent} + -- LIMIT 1 + -- |] + -- [key] @== keyFromRaw' - 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 + 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 -- TODO: put into persistent-qq test suite -- it "RawSql Entity instance with sqlQQ" $ runDb $ do @@ -245,17 +270,22 @@ -- [Entity key p1] @== newp1' matchK :: (PersistField a, PersistEntity record) => Key record -> Either Text a -matchK = (\(pv:[]) -> fromPersistValue pv) . keyToValues +matchK = (\(pv : []) -> fromPersistValue pv) . keyToValues -matchK2 :: (PersistField a1, PersistField a, PersistEntity record, PersistEntity record2) - => Key record -> Key record2 - -> Either Text (a1, a) +matchK2 + :: (PersistField a1, PersistField a, PersistEntity record, PersistEntity record2) + => Key record + -> Key record2 + -> Either Text (a1, a) matchK2 k1 k2 = (,) <$> matchK k1 <*> matchK k2 matchParentK :: Key TestParent -> Either Text (String, String, Int64) -matchParentK = (\(a:b:c:[]) -> (,,) <$> fromPersistValue a <*> fromPersistValue b <*> fromPersistValue c) - . keyToValues +matchParentK = + ( \(a : b : c : []) -> (,,) <$> fromPersistValue a <*> fromPersistValue b <*> fromPersistValue c + ) + . keyToValues matchCitizenAddressK :: Key CitizenAddress -> Either Text (Int64, Int64) -matchCitizenAddressK = (\(a:b:[]) -> (,) <$> fromPersistValue a <*> fromPersistValue b) - . keyToValues +matchCitizenAddressK = + (\(a : b : []) -> (,) <$> fromPersistValue a <*> fromPersistValue b) + . keyToValues diff --git a/src/CustomPersistField.hs b/src/CustomPersistField.hs --- a/src/CustomPersistField.hs +++ b/src/CustomPersistField.hs @@ -1,23 +1,28 @@ -- This module is used for CustomPersistFieldTest; the TH GHC stage restriction requires it to be here. -- The code is taken from the Yesod.Text.Markdown package; see https://github.com/yesodweb/persistent/issues/448 {-# LANGUAGE GeneralizedNewtypeDeriving #-} + module CustomPersistField where import Data.String (IsString) import Data.Text (pack) -import Data.Text.Lazy (toStrict, fromStrict) +import Data.Text.Lazy (fromStrict, toStrict) import qualified Data.Text.Lazy as TL (Text) import Init newtype Markdown = Markdown TL.Text - deriving (Eq, Ord, IsString, Show) + deriving (Eq, Ord, IsString, Show) instance PersistField Markdown where - toPersistValue (Markdown t) = PersistText $ toStrict t - fromPersistValue (PersistText t) = Right $ Markdown $ fromStrict t - fromPersistValue wrongValue = Left $ pack $ "Received " ++ show wrongValue ++ " when a value of type PersistText was expected." - + toPersistValue (Markdown t) = PersistText $ toStrict t + fromPersistValue (PersistText t) = Right $ Markdown $ fromStrict t + fromPersistValue wrongValue = + Left $ + pack $ + "Received " + ++ show wrongValue + ++ " when a value of type PersistText was expected." instance PersistFieldSql Markdown where sqlType _ = SqlString diff --git a/src/CustomPersistFieldTest.hs b/src/CustomPersistFieldTest.hs --- a/src/CustomPersistFieldTest.hs +++ b/src/CustomPersistFieldTest.hs @@ -1,21 +1,25 @@ -{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-} + module CustomPersistFieldTest (specsWith, customFieldMigrate) where import CustomPersistField import Init -share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "customFieldMigrate"] [persistLowerCase| +share + [mkPersist sqlSettings{mpsGeneric = True}, mkMigrate "customFieldMigrate"] + [persistLowerCase| BlogPost article Markdown deriving Show Eq |] -specsWith :: Runner backend m => RunDb backend m -> Spec +specsWith :: (Runner backend m) => RunDb backend m -> Spec specsWith runDB = describe "Custom persist field" $ do - it "should read what it wrote" $ runDB $ do - let originalBlogPost = BlogPost "article" - blogPostId <- insert originalBlogPost - Just newBlogPost <- get blogPostId - liftIO $ originalBlogPost @?= newBlogPost + it "should read what it wrote" $ runDB $ do + let + originalBlogPost = BlogPost "article" + blogPostId <- insert originalBlogPost + Just newBlogPost <- get blogPostId + liftIO $ originalBlogPost @?= newBlogPost diff --git a/src/CustomPrimaryKeyReferenceTest.hs b/src/CustomPrimaryKeyReferenceTest.hs --- a/src/CustomPrimaryKeyReferenceTest.hs +++ b/src/CustomPrimaryKeyReferenceTest.hs @@ -1,6 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} + -- This test is based on this issue: https://github.com/yesodweb/persistent/issues/421 -- The primary thing this is testing is the migration, thus the test code itself being mostly negligible. module CustomPrimaryKeyReferenceTest where @@ -8,7 +9,9 @@ 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 "migration"] [persistLowerCase| +share + [mkPersist persistSettings{mpsGeneric = False}, mkMigrate "migration"] + [persistLowerCase| Tweet tweetId Int statusText Text sqltype=varchar(170) @@ -23,16 +26,25 @@ deriving Show |] -cleanDB :: (MonadIO m, PersistQuery backend, PersistEntityBackend Tweet ~ backend) => ReaderT backend m () +cleanDB + :: (MonadIO m, PersistQuery backend, PersistEntityBackend Tweet ~ backend) + => ReaderT backend m () cleanDB = do - deleteWhere ([] :: [Filter Tweet]) - deleteWhere ([] :: [Filter TweetUrl]) + deleteWhere ([] :: [Filter Tweet]) + deleteWhere ([] :: [Filter TweetUrl]) specsWith :: (MonadFail m, MonadIO m) => RunDb SqlBackend m -> Spec specsWith runDb = describe "custom primary key reference" $ do - let tweet = Tweet {tweetTweetId = 1, tweetStatusText = "Hello!"} + let + tweet = Tweet{tweetTweetId = 1, tweetStatusText = "Hello!"} - it "can insert a Tweet" $ runDb $ do - tweetId <- insert tweet - let url = TweetUrl {tweetUrlTweetId = tweetId, tweetUrlTweetUrl = "http://google.com", tweetUrlFinalUrl = Just "http://example.com"} - insert_ url + it "can insert a Tweet" $ runDb $ do + tweetId <- insert tweet + let + url = + TweetUrl + { tweetUrlTweetId = tweetId + , tweetUrlTweetUrl = "http://google.com" + , tweetUrlFinalUrl = Just "http://example.com" + } + insert_ url diff --git a/src/DataTypeTest.hs b/src/DataTypeTest.hs --- a/src/DataTypeTest.hs +++ b/src/DataTypeTest.hs @@ -1,7 +1,8 @@ {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-} + module DataTypeTest ( specsWith , dataTypeMigrate @@ -15,13 +16,19 @@ import Data.Foldable (for_) import Data.IntMap (IntMap) import qualified Data.Text as T -import Data.Time (Day, UTCTime (..), TimeOfDay, timeToTimeOfDay, timeOfDayToTime) -import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime) +import Data.Time + ( Day + , TimeOfDay + , UTCTime (..) + , timeOfDayToTime + , timeToTimeOfDay + ) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) +import Database.Persist.Class.PersistEntity import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary) -import Test.QuickCheck.Gen (Gen(..)) +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 @@ -29,7 +36,9 @@ type Tuple a b = (a, b) -- Test lower case names -share [mkPersist persistSettings, mkMigrate "dataTypeMigrate"] [persistLowerCase| +share + [mkPersist persistSettings, mkMigrate "dataTypeMigrate"] + [persistLowerCase| DataTypeTable no-json text Text textMaxLen Text maxlen=100 @@ -46,11 +55,11 @@ |] cleanDB' - :: - ( MonadIO m, PersistStoreWrite (BaseBackend backend), PersistQuery backend) => ReaderT backend m () + :: (MonadIO m, PersistStoreWrite (BaseBackend backend), PersistQuery backend) + => ReaderT backend m () cleanDB' = deleteWhere ([] :: [Filter (DataTypeTableGeneric backend)]) -roundFn :: RealFrac a => a -> Integer +roundFn :: (RealFrac a) => a -> Integer roundFn = truncate roundTime :: TimeOfDay -> TimeOfDay @@ -60,41 +69,42 @@ roundUTCTime t = posixSecondsToUTCTime $ fromIntegral $ roundFn $ utcTimeToPOSIXSeconds t -randomValues :: Arbitrary a => Int -> IO [a] +randomValues :: (Arbitrary a) => Int -> IO [a] randomValues i = do - gs <- replicateM i newQCGen - return $ zipWith (unGen arbitrary) gs [0..] + gs <- replicateM i newQCGen + return $ zipWith (unGen arbitrary) gs [0 ..] instance Arbitrary DataTypeTable where - arbitrary = DataTypeTable - <$> arbText -- text - <*> (T.take 100 <$> arbText) -- textManLen - <*> arbitrary -- bytes - <*> liftA2 (,) arbitrary arbText -- bytesTextTuple - <*> (BS.take 100 <$> arbitrary) -- bytesMaxLen - <*> arbitrary -- int - <*> arbitrary -- intList - <*> arbitrary -- intMap - <*> arbitrary -- double - <*> arbitrary -- bool - <*> arbitrary -- day - <*> (truncateUTCTime =<< arbitrary) -- utc + arbitrary = + DataTypeTable + <$> arbText -- text + <*> (T.take 100 <$> arbText) -- textManLen + <*> arbitrary -- bytes + <*> liftA2 (,) arbitrary arbText -- bytesTextTuple + <*> (BS.take 100 <$> arbitrary) -- bytesMaxLen + <*> arbitrary -- int + <*> arbitrary -- intList + <*> arbitrary -- intMap + <*> arbitrary -- double + <*> arbitrary -- bool + <*> arbitrary -- day + <*> (truncateUTCTime =<< arbitrary) -- utc specsWith - :: forall db backend m entity. - ( db ~ ReaderT backend m - , PersistStoreRead backend - , PersistEntity entity - , PersistEntityBackend entity ~ BaseBackend backend - , Arbitrary entity - , PersistStoreWrite backend - , PersistStoreWrite (BaseBackend backend) - , PersistQueryWrite (BaseBackend backend) - , PersistQueryWrite backend - , MonadFail m - , MonadIO m - , SafeToInsert entity - ) + :: forall db backend m entity + . ( db ~ ReaderT backend m + , PersistStoreRead backend + , PersistEntity entity + , PersistEntityBackend entity ~ BaseBackend backend + , Arbitrary entity + , PersistStoreWrite backend + , PersistStoreWrite (BaseBackend backend) + , PersistQueryWrite (BaseBackend backend) + , PersistQueryWrite backend + , MonadFail m + , MonadIO m + , SafeToInsert entity + ) => (db () -> IO ()) -- ^ DB Runner -> Maybe (db [Text]) @@ -106,34 +116,39 @@ -> (entity -> Double) -> Spec specsWith runDb mmigration checks apprxChecks doubleFn = describe "data type specs" $ - it "handles all types" $ asIO $ runDb $ do - - _ <- sequence_ mmigration - -- Ensure reading the data from the database works... - _ <- sequence_ mmigration - cleanDB' - rvals <- liftIO $ randomValues 1000 - for_ rvals $ \x -> do - key <- insert x - Just y <- get key - liftIO $ do - let check :: (Eq a, Show a, HasCallStack) => String -> (entity -> a) -> IO () - check s f = (s, f x) @=? (s, f y) - -- Check floating-point near equality - let check' :: (Fractional p, Show p, Real p, HasCallStack) => String -> (entity -> p) -> IO () - check' s f - | abs (f x - f y) < 0.000001 = return () - | otherwise = (s, f x) @=? (s, f y) - -- Check individual fields for better error messages - for_ checks $ \(TestFn msg f) -> check msg f - for_ apprxChecks $ \(msg, f) -> check' msg f + it "handles all types" $ + asIO $ + runDb $ do + _ <- sequence_ mmigration + -- Ensure reading the data from the database works... + _ <- sequence_ mmigration + cleanDB' + rvals <- liftIO $ randomValues 1000 + for_ rvals $ \x -> do + key <- insert x + Just y <- get key + liftIO $ do + let + check :: (Eq a, Show a, HasCallStack) => String -> (entity -> a) -> IO () + check s f = (s, f x) @=? (s, f y) + -- Check floating-point near equality + let + check' + :: (Fractional p, Show p, Real p, HasCallStack) => String -> (entity -> p) -> IO () + check' s f + | abs (f x - f y) < 0.000001 = return () + | otherwise = (s, f x) @=? (s, f y) + -- Check individual fields for better error messages + for_ checks $ \(TestFn msg f) -> check msg f + for_ apprxChecks $ \(msg, f) -> check' msg f - -- Do a special check for Double since it may - -- lose precision when serialized. - when (getDoubleDiff (doubleFn x) (doubleFn y) > 1e-14) $ - check "double" doubleFn - where - normDouble :: Double -> Double - normDouble x | abs x > 1 = x / 10 ^ (truncate (logBase 10 (abs x)) :: Integer) - | otherwise = x - getDoubleDiff x y = abs (normDouble x - normDouble y) + -- Do a special check for Double since it may + -- lose precision when serialized. + when (getDoubleDiff (doubleFn x) (doubleFn y) > 1e-14) $ + check "double" doubleFn + where + normDouble :: Double -> Double + normDouble x + | abs x > 1 = x / 10 ^ (truncate (logBase 10 (abs x)) :: Integer) + | otherwise = x + getDoubleDiff x y = abs (normDouble x - normDouble y) diff --git a/src/EmbedOrderTest.hs b/src/EmbedOrderTest.hs --- a/src/EmbedOrderTest.hs +++ b/src/EmbedOrderTest.hs @@ -1,6 +1,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-} + module EmbedOrderTest (specsWith, embedOrderMigrate, cleanDB) where import qualified Data.Map as Map @@ -8,10 +9,12 @@ import Init -debug :: Show s => s -> s +debug :: (Show s) => s -> s debug x = trace (show x) x -share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "embedOrderMigrate"] [persistUpperCase| +share + [mkPersist sqlSettings{mpsGeneric = True}, mkMigrate "embedOrderMigrate"] + [persistUpperCase| Foo sql=foo_embed_order bars [Bar] deriving Eq Show @@ -22,23 +25,25 @@ deriving Eq Show |] -cleanDB :: Runner backend m => ReaderT backend m () +cleanDB :: (Runner backend m) => ReaderT backend m () cleanDB = do - deleteWhere ([] :: [Filter (FooGeneric backend)]) - deleteWhere ([] :: [Filter (BarGeneric backend)]) + deleteWhere ([] :: [Filter (FooGeneric backend)]) + deleteWhere ([] :: [Filter (BarGeneric backend)]) -specsWith :: Runner backend m => RunDb backend m -> Spec +specsWith :: (Runner backend m) => RunDb backend m -> Spec specsWith db = describe "embedded entities" $ do it "preserves ordering" $ db $ do - let foo = Foo [Bar "b" "u" "g"] + let + foo = Foo [Bar "b" "u" "g"] fooId <- insert foo Just otherFoo <- get fooId foo @== otherFoo it "PersistMap PersistValue serializaion" $ db $ do - let record = Map.fromList [("b" :: Text,"b" :: Text),("u","u"),("g","g")] + let + record = Map.fromList [("b" :: Text, "b" :: Text), ("u", "u"), ("g", "g")] record @== (fromRight . fromPersistValue . toPersistValue) record -fromRight :: Show a => Either a b -> b +fromRight :: (Show a) => Either a b -> b fromRight (Left e) = error $ "expected Right, got Left " ++ show e fromRight (Right x) = x diff --git a/src/EmbedTest.hs b/src/EmbedTest.hs --- a/src/EmbedTest.hs +++ b/src/EmbedTest.hs @@ -1,14 +1,15 @@ -{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans -O0 #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-} + module EmbedTest (specsWith, cleanDB, embedMigrate) where import Control.Exception (Exception, throw) import Data.List.NonEmpty hiding (insert, length) import qualified Data.Map as M -import qualified Data.Text as T import qualified Data.Set as S +import qualified Data.Text as T import EntityEmbedTest import Init @@ -17,19 +18,20 @@ deriving (Show, Eq) instance Exception TestException -instance PersistFieldSql a => PersistFieldSql (NonEmpty a) where +instance (PersistFieldSql a) => PersistFieldSql (NonEmpty a) where sqlType _ = SqlString -instance PersistField a => PersistField (NonEmpty a) where +instance (PersistField a) => PersistField (NonEmpty a) where toPersistValue = toPersistValue . toList fromPersistValue pv = do xs <- fromPersistValue pv case xs of [] -> Left "PersistField: NonEmpty found unexpected Empty List" - (l:ls) -> Right (l:|ls) - + (l : ls) -> Right (l :| ls) -share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "embedMigrate"] [persistUpperCase| +share + [mkPersist sqlSettings{mpsGeneric = True}, mkMigrate "embedMigrate"] + [persistUpperCase| OnlyName name Text @@ -136,130 +138,161 @@ -- SelfDirect -- reference SelfDirect |] -cleanDB :: (PersistQuery backend, PersistEntityBackend HasMap ~ backend, MonadIO m) => ReaderT backend m () +cleanDB + :: (PersistQuery backend, PersistEntityBackend HasMap ~ backend, MonadIO m) + => ReaderT backend m () cleanDB = do - deleteWhere ([] :: [Filter (HasEmbedGeneric backend)]) - deleteWhere ([] :: [Filter (HasEmbedsGeneric backend)]) - deleteWhere ([] :: [Filter (HasListEmbedGeneric backend)]) - deleteWhere ([] :: [Filter (HasSetEmbedGeneric backend)]) - deleteWhere ([] :: [Filter (UserGeneric backend)]) - deleteWhere ([] :: [Filter (HasMapGeneric backend)]) - deleteWhere ([] :: [Filter (HasListGeneric backend)]) - deleteWhere ([] :: [Filter (EmbedsHasMapGeneric backend)]) - deleteWhere ([] :: [Filter (ListEmbedGeneric backend)]) - deleteWhere ([] :: [Filter (ARecordGeneric backend)]) - deleteWhere ([] :: [Filter (AccountGeneric backend)]) - deleteWhere ([] :: [Filter (HasNestedListGeneric backend)]) + deleteWhere ([] :: [Filter (HasEmbedGeneric backend)]) + deleteWhere ([] :: [Filter (HasEmbedsGeneric backend)]) + deleteWhere ([] :: [Filter (HasListEmbedGeneric backend)]) + deleteWhere ([] :: [Filter (HasSetEmbedGeneric backend)]) + deleteWhere ([] :: [Filter (UserGeneric backend)]) + deleteWhere ([] :: [Filter (HasMapGeneric backend)]) + deleteWhere ([] :: [Filter (HasListGeneric backend)]) + deleteWhere ([] :: [Filter (EmbedsHasMapGeneric backend)]) + deleteWhere ([] :: [Filter (ListEmbedGeneric backend)]) + deleteWhere ([] :: [Filter (ARecordGeneric backend)]) + deleteWhere ([] :: [Filter (AccountGeneric backend)]) + deleteWhere ([] :: [Filter (HasNestedListGeneric backend)]) -_unlessM :: MonadIO m => IO Bool -> m () -> m () +_unlessM :: (MonadIO m) => IO Bool -> m () -> m () _unlessM predicate body = do b <- liftIO predicate unless b body -specsWith :: Runner SqlBackend m => RunDb SqlBackend m -> Spec +specsWith :: (Runner SqlBackend m) => RunDb SqlBackend m -> Spec specsWith runDb = describe "embedded entities" $ do - - it "simple entities" $ runDb $ do - let container = HasEmbeds "container" (OnlyName "2") - (HasEmbed "embed" (OnlyName "1")) - contK <- insert container - Just res <- selectFirst [HasEmbedsName ==. "container"] [] - res @== Entity contK container + it "simple entities" $ runDb $ do + let + container = + HasEmbeds + "container" + (OnlyName "2") + (HasEmbed "embed" (OnlyName "1")) + contK <- insert container + Just res <- selectFirst [HasEmbedsName ==. "container"] [] + res @== Entity contK container - it "query for equality of embeded entity" $ runDb $ do - let container = HasEmbed "container" (OnlyName "2") - contK <- insert container - Just res <- selectFirst [HasEmbedEmbed ==. OnlyName "2"] [] - res @== Entity contK container + it "query for equality of embeded entity" $ runDb $ do + let + container = HasEmbed "container" (OnlyName "2") + contK <- insert container + Just res <- selectFirst [HasEmbedEmbed ==. OnlyName "2"] [] + res @== Entity contK container - it "Set" $ runDb $ do - let container = HasSetEmbed "set" $ S.fromList - [ HasEmbed "embed" (OnlyName "1") - , HasEmbed "embed" (OnlyName "2") - ] - contK <- insert container - Just res <- selectFirst [HasSetEmbedName ==. "set"] [] - res @== Entity contK container + it "Set" $ runDb $ do + let + container = + HasSetEmbed "set" $ + S.fromList + [ HasEmbed "embed" (OnlyName "1") + , HasEmbed "embed" (OnlyName "2") + ] + contK <- insert container + Just res <- selectFirst [HasSetEmbedName ==. "set"] [] + res @== Entity contK container - it "Set empty" $ runDb $ do - let container = HasSetEmbed "set empty" $ S.fromList [] - contK <- insert container - Just res <- selectFirst [HasSetEmbedName ==. "set empty"] [] - res @== Entity contK container + it "Set empty" $ runDb $ do + let + container = HasSetEmbed "set empty" $ S.fromList [] + contK <- insert container + Just res <- selectFirst [HasSetEmbedName ==. "set empty"] [] + res @== Entity contK container - it "exception" $ flip shouldThrow (== TestException) $ runDb $ do - let container = HasSetEmbed "set" $ S.fromList - [ HasEmbed "embed" (OnlyName "1") - , HasEmbed "embed" (OnlyName "2") - ] - contK <- insert container - Just res <- selectFirst [HasSetEmbedName ==. throw TestException] [] - res @== Entity contK container + it "exception" $ flip shouldThrow (== TestException) $ runDb $ do + let + container = + HasSetEmbed "set" $ + S.fromList + [ HasEmbed "embed" (OnlyName "1") + , HasEmbed "embed" (OnlyName "2") + ] + contK <- insert container + Just res <- selectFirst [HasSetEmbedName ==. throw TestException] [] + res @== Entity contK container - it "ListEmbed" $ runDb $ do - let container = HasListEmbed "list" - [ HasEmbed "embed" (OnlyName "1") - , HasEmbed "embed" (OnlyName "2") - ] - contK <- insert container - Just res <- selectFirst [HasListEmbedName ==. "list"] [] - res @== Entity contK container + it "ListEmbed" $ runDb $ do + let + container = + HasListEmbed + "list" + [ HasEmbed "embed" (OnlyName "1") + , HasEmbed "embed" (OnlyName "2") + ] + contK <- insert container + Just res <- selectFirst [HasListEmbedName ==. "list"] [] + res @== Entity contK container - it "ListEmbed empty" $ runDb $ do - let container = HasListEmbed "list empty" [] - contK <- insert container - Just res <- selectFirst [HasListEmbedName ==. "list empty"] [] - res @== Entity contK container + it "ListEmbed empty" $ runDb $ do + let + container = HasListEmbed "list empty" [] + contK <- insert container + Just res <- selectFirst [HasListEmbedName ==. "list empty"] [] + res @== Entity contK container - it "List empty" $ runDb $ do - let container = HasList [] - contK <- insert container - Just res <- selectFirst [] [] - res @== Entity contK container + it "List empty" $ runDb $ do + let + container = HasList [] + contK <- insert container + Just res <- selectFirst [] [] + res @== Entity contK container - it "NonEmpty List wrapper" $ runDb $ do - let con = Contact 123456 "foo@bar.com" - let prof = Profile "fstN" "lstN" (Just con) - uid <- insert $ User "foo" (Just "pswd") prof - let container = Account (uid:|[]) (Just "Account") [] - contK <- insert container - Just res <- selectFirst [AccountUserIds ==. (uid:|[])] [] - res @== Entity contK container + it "NonEmpty List wrapper" $ runDb $ do + let + con = Contact 123456 "foo@bar.com" + let + prof = Profile "fstN" "lstN" (Just con) + uid <- insert $ User "foo" (Just "pswd") prof + let + container = Account (uid :| []) (Just "Account") [] + contK <- insert container + Just res <- selectFirst [AccountUserIds ==. (uid :| [])] [] + res @== Entity contK container - it "Map" $ runDb $ do - let container = HasMap "2 items" $ M.fromList [ - ("k1","v1") - , ("k2","v2") - ] - contK <- insert container - Just res <- selectFirst [HasMapName ==. "2 items"] [] - res @== Entity contK container + it "Map" $ runDb $ do + let + container = + HasMap "2 items" $ + M.fromList + [ ("k1", "v1") + , ("k2", "v2") + ] + contK <- insert container + Just res <- selectFirst [HasMapName ==. "2 items"] [] + res @== Entity contK container - it "Map empty" $ runDb $ do - let container = HasMap "empty" $ M.fromList [] - contK <- insert container - Just res <- selectFirst [HasMapName ==. "empty"] [] - res @== Entity contK container + it "Map empty" $ runDb $ do + let + container = HasMap "empty" $ M.fromList [] + contK <- insert container + Just res <- selectFirst [HasMapName ==. "empty"] [] + res @== Entity contK container - it "Embeds a Map" $ runDb $ do - let container = EmbedsHasMap (Just "non-empty map") $ HasMap "2 items" $ M.fromList [ - ("k1","v1") - , ("k2","v2") - ] - contK <- insert container - Just res <- selectFirst [EmbedsHasMapName ==. Just "non-empty map"] [] - res @== Entity contK container + it "Embeds a Map" $ runDb $ do + let + container = + EmbedsHasMap (Just "non-empty map") $ + HasMap "2 items" $ + M.fromList + [ ("k1", "v1") + , ("k2", "v2") + ] + contK <- insert container + Just res <- selectFirst [EmbedsHasMapName ==. Just "non-empty map"] [] + res @== Entity contK container - it "Embeds a Map empty" $ runDb $ do - let container = EmbedsHasMap (Just "empty map") $ HasMap "empty" $ M.fromList [] - contK <- insert container - Just res <- selectFirst [EmbedsHasMapName ==. Just "empty map"] [] - res @== Entity contK container + it "Embeds a Map empty" $ runDb $ do + let + container = EmbedsHasMap (Just "empty map") $ HasMap "empty" $ M.fromList [] + contK <- insert container + Just res <- selectFirst [EmbedsHasMapName ==. Just "empty map"] [] + res @== Entity contK container - it "Embeds a Map with ids as values" $ runDb $ do - onId <- insert $ OnlyName "nombre" - onId2 <- insert $ OnlyName "nombre2" - let midValue = MapIdValue $ M.fromList [("foo", onId),("bar",onId2)] - mK <- insert midValue - Just mv <- get mK - mv @== midValue + it "Embeds a Map with ids as values" $ runDb $ do + onId <- insert $ OnlyName "nombre" + onId2 <- insert $ OnlyName "nombre2" + let + midValue = MapIdValue $ M.fromList [("foo", onId), ("bar", onId2)] + mK <- insert midValue + Just mv <- get mK + mv @== midValue diff --git a/src/EmptyEntityTest.hs b/src/EmptyEntityTest.hs --- a/src/EmptyEntityTest.hs +++ b/src/EmptyEntityTest.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-} + module EmptyEntityTest (specsWith, migration, cleanDB) where import Database.Persist.Sql @@ -9,29 +10,32 @@ import Init -- Test lower case names -share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "migration"] [persistLowerCase| +share + [mkPersist sqlSettings{mpsGeneric = True}, mkMigrate "migration"] + [persistLowerCase| EmptyEntity |] cleanDB - :: - ( PersistQueryWrite backend - , MonadIO m - , PersistStoreWrite (BaseBackend backend) - ) + :: ( PersistQueryWrite backend + , MonadIO m + , PersistStoreWrite (BaseBackend backend) + ) => ReaderT backend m () cleanDB = deleteWhere ([] :: [Filter (EmptyEntityGeneric backend)]) specsWith - :: Runner backend m + :: (Runner backend m) => RunDb backend m -> Maybe (ReaderT backend m a) -> Spec specsWith runConn mmigrate = describe "empty entity" $ - it "inserts" $ asIO $ runConn $ do - _ <- sequence_ mmigrate - -- Ensure reading the data from the database works... - _ <- sequence_ mmigrate - x <- insert EmptyEntity - Just EmptyEntity <- get x - return () + it "inserts" $ + asIO $ + runConn $ do + _ <- sequence_ mmigrate + -- Ensure reading the data from the database works... + _ <- sequence_ mmigrate + x <- insert EmptyEntity + Just EmptyEntity <- get x + return () diff --git a/src/EntityEmbedTest.hs b/src/EntityEmbedTest.hs --- a/src/EntityEmbedTest.hs +++ b/src/EntityEmbedTest.hs @@ -1,12 +1,15 @@ -{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + module EntityEmbedTest where -- because we are using a type alias we need to declare in a separate module -- this is used in EmbedTest import Init -mkPersist persistSettings { mpsGeneric = True } [persistUpperCase| +mkPersist + persistSettings{mpsGeneric = True} + [persistUpperCase| ARecord name Text deriving Show Eq Read Ord diff --git a/src/EquivalentTypeTest.hs b/src/EquivalentTypeTest.hs --- a/src/EquivalentTypeTest.hs +++ b/src/EquivalentTypeTest.hs @@ -10,19 +10,23 @@ import Database.Persist.TH import Init -share [mkPersist sqlSettings, mkMigrate "migrateAll1"] [persistLowerCase| +share + [mkPersist sqlSettings, mkMigrate "migrateAll1"] + [persistLowerCase| EquivalentType sql=equivalent_types field1 Int deriving Eq Show |] -share [mkPersist sqlSettings, mkMigrate "migrateAll2"] [persistLowerCase| +share + [mkPersist sqlSettings, mkMigrate "migrateAll2"] + [persistLowerCase| EquivalentType2 sql=equivalent_types field1 Int deriving Eq Show |] -specsWith :: Runner SqlBackend m => RunDb SqlBackend m -> Spec +specsWith :: (Runner SqlBackend m) => RunDb SqlBackend m -> Spec specsWith runDb = describe "doesn't migrate equivalent types" $ do it "works" $ runDb $ do _ <- runMigrationSilent migrateAll1 diff --git a/src/ForeignKey.hs b/src/ForeignKey.hs --- a/src/ForeignKey.hs +++ b/src/ForeignKey.hs @@ -1,18 +1,23 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE AllowAmbiguousTypes, GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables, TypeApplications, UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} module ForeignKey where -import Data.Proxy import qualified Data.List as List +import Data.Proxy 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| +share + [mkPersist persistSettings{mpsGeneric = False}, mkMigrate "compositeMigrate"] + [persistLowerCase| SimpleCascadeChild ref SimpleCascadeId OnDeleteCascade deriving Show Eq @@ -109,7 +114,8 @@ insert_ $ Child 1 delete kf cs <- selectList [] [] - let expected = [] :: [Entity Child] + let + expected = [] :: [Entity Child] cs @== expected it "update cascades" $ runDb $ do kf <- insert $ Parent 1 @@ -122,14 +128,16 @@ insert_ $ ChildComposite 1 2 delete kf cs <- selectList [] [] - let expected = [] :: [Entity ChildComposite] + 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] + let + expected = [] :: [Entity SelfReferenced] srs @== expected it "delete cascade works on simple references" $ runDb $ do scId <- insert $ SimpleCascade 1 @@ -147,7 +155,8 @@ delete kf return () cs <- selectList [] [] - let expected = [] :: [Entity B] + let + expected = [] :: [Entity B] cs @== expected it "delete cascades with explicit Composite Reference" $ runDb $ do kf <- insert $ AComposite 1 20 @@ -155,7 +164,8 @@ delete kf return () cs <- selectList [] [] - let expected = [] :: [Entity B] + let + expected = [] :: [Entity B] cs @== expected it "delete cascades with explicit Composite Reference" $ runDb $ do kf <- insert $ AComposite 1 20 @@ -163,7 +173,8 @@ delete kf return () cs <- selectList [] [] - let expected = [] :: [Entity B] + let + expected = [] :: [Entity B] cs @== expected it "delete cascades with explicit Id field" $ runDb $ do kf <- insert $ A 1 20 @@ -171,14 +182,16 @@ delete kf return () cs <- selectList [] [] - let expected = [] :: [Entity B] + 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}] + 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 @@ -186,7 +199,8 @@ insert_ $ Chain2 3 (Just k2) delete k1 cs <- selectList [] [] - let expected = [] :: [Entity Chain2] + let + expected = [] :: [Entity Chain2] cs @== expected it "deletes cascades with field self reference to the whole chain" $ runDb $ do k1 <- insert $ Chain3 1 Nothing @@ -194,28 +208,30 @@ insert_ $ Chain3 3 (Just k2) delete k1 cs <- selectList [] [] - let expected = [] :: [Entity Chain3] + let + expected = [] :: [Entity Chain3] cs @== expected describe "EntityDef" $ do - let ed = + let + ed = entityDef (Proxy @SimpleCascadeChild) isRefCol = (FieldNameHS "ref" ==) . fieldHaskell - expected = FieldCascade - { fcOnUpdate = Nothing - , fcOnDelete = Just Cascade - } + expected = + FieldCascade + { fcOnUpdate = Nothing + , fcOnDelete = Just Cascade + } Just refField = List.find isRefCol (getEntityFields ed) - it "parses into fieldCascade" $ do + it "parses into fieldCascade" $ do fieldCascade refField `shouldBe` expected it "shouldn't have cascade in extras" $ do entityExtra ed - `shouldBe` - mempty + `shouldBe` mempty cleanDB :: (MonadIO m) => SqlPersistT m () cleanDB = do @@ -237,10 +253,10 @@ del @Chain2 del - :: forall a m. - ( PersistEntity a - , PersistEntityBackend a ~ SqlBackend - , MonadIO m - ) + :: 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 --- a/src/GeneratedColumnTestSQL.hs +++ b/src/GeneratedColumnTestSQL.hs @@ -2,12 +2,15 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-} + module GeneratedColumnTestSQL (specsWith) where import Database.Persist.TH import Init -share [mkPersist sqlSettings, mkMigrate "migrate1"] [persistLowerCase| +share + [mkPersist sqlSettings, mkMigrate "migrate1"] + [persistLowerCase| GenTest sql=gen_test fieldOne Text Maybe fieldTwo Text Maybe @@ -19,31 +22,34 @@ cromulence Int generated=5 |] -share [mkPersist sqlSettings, mkMigrate "migrate2"] [persistLowerCase| +share + [mkPersist sqlSettings, mkMigrate "migrate2"] + [persistLowerCase| MigrateTestV2 sql=gen_migrate_test sickness Int generated=3 cromulence Int |] -specsWith :: Runner SqlBackend m => RunDb SqlBackend m -> Spec +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 - } + 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 + liftIO $ cromulence1 @?= 5 it "should support adding or removing generation expressions from columns" $ runDB $ do runMigration migrate2 diff --git a/src/HtmlTest.hs b/src/HtmlTest.hs --- a/src/HtmlTest.hs +++ b/src/HtmlTest.hs @@ -1,29 +1,33 @@ -{-# LANGUAGE DataKinds, UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-} + module HtmlTest (specsWith, cleanDB, htmlMigrate) where -import Data.Char (generalCategory, GeneralCategory(..)) +import Data.Char (GeneralCategory (..), generalCategory) import qualified Data.Text as T -import System.Random (randomIO, randomRIO, Random) +import System.Random (Random, randomIO, randomRIO) import Text.Blaze.Html import Text.Blaze.Html.Renderer.Text import Init -- Test lower case names -share [mkPersist persistSettings { mpsGeneric = True }, mkMigrate "htmlMigrate"] [persistLowerCase| +share + [mkPersist persistSettings{mpsGeneric = True}, mkMigrate "htmlMigrate"] + [persistLowerCase| HtmlTable html Html deriving |] -cleanDB :: Runner backend m => ReaderT backend m () +cleanDB :: (Runner backend m) => ReaderT backend m () cleanDB = do - deleteWhere ([] :: [Filter (HtmlTableGeneric backend)]) + deleteWhere ([] :: [Filter (HtmlTableGeneric backend)]) specsWith - :: Runner backend m + :: (Runner backend m) => RunDb backend m -> Maybe (ReaderT backend m a) -> Spec @@ -42,15 +46,16 @@ randomValue :: IO Html randomValue = - preEscapedToMarkup - . T.pack - . filter ((`notElem` forbidden) . generalCategory) - . filter (<= '\xFFFF') -- only BMP - . filter (/= '\0') -- no nulls - <$> randomIOs - where forbidden = [NotAssigned, PrivateUse] + preEscapedToMarkup + . T.pack + . filter ((`notElem` forbidden) . generalCategory) + . filter (<= '\xFFFF') -- only BMP + . filter (/= '\0') -- no nulls + <$> randomIOs + where + forbidden = [NotAssigned, PrivateUse] -randomIOs :: Random a => IO [a] +randomIOs :: (Random a) => IO [a] randomIOs = do len <- randomRIO (0, 20) sequence $ replicate len randomIO diff --git a/src/Init.hs b/src/Init.hs --- a/src/Init.hs +++ b/src/Init.hs @@ -8,46 +8,52 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | This will hopefully be the only module with CPP in it. -module Init ( - (@/=), (@==), (==@) - , asIO - , assertNotEqual - , assertNotEmpty - , assertEmpty - , isTravis - - , module Database.Persist.Sql - , persistSettings - , MkPersistSettings (..) - , BackendKey(..) - , GenerateKey(..) - - , RunDb - , Runner - -- re-exports - , module Database.Persist - , module Test.Hspec - , module Test.HUnit - , mkPersist, mkMigrate, share, sqlSettings, persistLowerCase, persistUpperCase - , Int32, Int64 - , Text - , module Control.Monad.Reader - , module Control.Monad - , module Control.Monad.IO.Unlift - , BS.ByteString - , SomeException - , MonadFail - , TestFn(..) - , truncateTimeOfDay - , truncateToMicro - , truncateUTCTime - , arbText - , liftA2 - , changeBackend - , Proxy(..) - , UUID(..) - , sqlSettingsUuid - ) where +module Init + ( (@/=) + , (@==) + , (==@) + , asIO + , assertNotEqual + , assertNotEmpty + , assertEmpty + , isTravis + , module Database.Persist.Sql + , persistSettings + , MkPersistSettings (..) + , BackendKey (..) + , GenerateKey (..) + , RunDb + , Runner + -- re-exports + , module Database.Persist + , module Test.Hspec + , module Test.HUnit + , mkPersist + , mkMigrate + , share + , sqlSettings + , persistLowerCase + , persistUpperCase + , Int32 + , Int64 + , Text + , module Control.Monad.Reader + , module Control.Monad + , module Control.Monad.IO.Unlift + , BS.ByteString + , SomeException + , MonadFail + , TestFn (..) + , truncateTimeOfDay + , truncateToMicro + , truncateUTCTime + , arbText + , 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 @@ -72,7 +78,7 @@ import Control.Monad (forM_, liftM, replicateM, void, when) import Control.Monad.Fail (MonadFail) import Control.Monad.Reader -import Data.Char (GeneralCategory(..), generalCategory) +import Data.Char (GeneralCategory (..), generalCategory) import Data.Fixed (Micro, Pico) import Data.Proxy import Data.String (IsString, fromString) @@ -81,19 +87,19 @@ import Test.Hspec import Test.QuickCheck.Instances () -import Data.Aeson (FromJSON, ToJSON, Value(..)) +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 - ) + ( MkPersistSettings (..) + , mkMigrate + , mkPersist + , persistLowerCase + , persistUpperCase + , setImplicitIdDef + , share + , sqlSettings + ) import Web.Internal.HttpApiData import Web.PathPieces @@ -116,12 +122,11 @@ -- Data types import Data.Int (Int32, Int64) - asIO :: IO a -> IO a asIO a = a (@/=), (@==), (==@) :: (HasCallStack, Eq a, Show a, MonadIO m) => a -> a -> m () -infix 1 @/= --, /=@ +infix 1 @/= -- , /=@ actual @/= expected = liftIO $ assertNotEqual "" expected actual infix 1 @==, ==@ @@ -132,12 +137,16 @@ expected /=@ actual = liftIO $ assertNotEqual "" expected actual -} - assertNotEqual :: (Eq a, Show a, HasCallStack) => String -> a -> a -> Assertion assertNotEqual preface expected actual = - unless (actual /= expected) (assertFailure msg) - where msg = (if null preface then "" else preface ++ "\n") ++ - "expected: " ++ show expected ++ "\n to not equal: " ++ show actual + unless (actual /= expected) (assertFailure msg) + where + msg = + (if null preface then "" else preface ++ "\n") + ++ "expected: " + ++ show expected + ++ "\n to not equal: " + ++ show actual assertEmpty :: (MonadIO m) => [a] -> m () assertEmpty xs = liftIO $ assertBool "" (null xs) @@ -149,25 +158,24 @@ isTravis = isCI isCI :: IO Bool -isCI = do +isCI = do env <- liftIO getEnvironment return $ case lookup "TRAVIS" env <|> lookup "CI" env of Just "true" -> True _ -> False - persistSettings :: MkPersistSettings -persistSettings = sqlSettings { mpsGeneric = True } +persistSettings = sqlSettings{mpsGeneric = True} instance Arbitrary PersistValue where arbitrary = PersistInt64 `fmap` choose (0, maxBound) -instance PersistStore backend => Arbitrary (BackendKey backend) where - arbitrary = (errorLeft . fromPersistValue) `fmap` arbitrary - where - errorLeft x = case x of - Left e -> error $ unpack e - Right r -> r +instance (PersistStore backend) => Arbitrary (BackendKey backend) where + arbitrary = (errorLeft . fromPersistValue) `fmap` arbitrary + where + errorLeft x = case x of + Left e -> error $ unpack e + Right r -> r class GenerateKey backend where generateKey :: IO (BackendKey backend) @@ -199,36 +207,44 @@ truncateTimeOfDay :: TimeOfDay -> Gen TimeOfDay truncateTimeOfDay (TimeOfDay h m s) = - return $ TimeOfDay h m $ truncateToMicro s + return $ TimeOfDay h m $ truncateToMicro s -- truncate less significant digits truncateToMicro :: Pico -> Pico -truncateToMicro p = let - p' = fromRational . toRational $ p :: Micro - in fromRational . toRational $ p' :: Pico +truncateToMicro p = + let + p' = fromRational . toRational $ p :: Micro + in + fromRational . toRational $ p' :: Pico truncateUTCTime :: UTCTime -> Gen UTCTime truncateUTCTime (UTCTime d dift) = do - let pico = fromRational . toRational $ dift :: Pico - picoi= truncate . (*1000000000000) . toRational $ truncateToMicro pico :: Integer - -- https://github.com/lpsmith/postgresql-simple/issues/123 - d' = max d $ fromGregorian 1950 1 1 - return $ UTCTime d' $ picosecondsToDiffTime picoi + let + pico = fromRational . toRational $ dift :: Pico + picoi = truncate . (* 1000000000000) . toRational $ truncateToMicro pico :: Integer + -- https://github.com/lpsmith/postgresql-simple/issues/123 + d' = max d $ fromGregorian 1950 1 1 + return $ UTCTime d' $ picosecondsToDiffTime picoi -arbText :: IsString s => Gen s +arbText :: (IsString s) => Gen s arbText = - fromString - . filter ((`notElem` forbidden) . generalCategory) - . filter (<= '\xFFFF') -- only BMP - . filter (/= '\0') -- no nulls - . T.unpack - <$> arbitrary - where forbidden = [NotAssigned, PrivateUse] + fromString + . filter ((`notElem` forbidden) . generalCategory) + . filter (<= '\xFFFF') -- only BMP + . filter (/= '\0') -- no nulls + . T.unpack + <$> arbitrary + where + forbidden = [NotAssigned, PrivateUse] type Runner backend m = - ( MonadIO m, MonadUnliftIO m, MonadFail m - , MonadThrow m, MonadBaseControl IO m - , PersistStoreWrite backend, PersistStoreWrite (BaseBackend backend) + ( MonadIO m + , MonadUnliftIO m + , MonadFail m + , MonadThrow m + , MonadBaseControl IO m + , PersistStoreWrite backend + , PersistStoreWrite (BaseBackend backend) , GenerateKey backend , HasPersistBackend backend , PersistUniqueWrite backend @@ -240,7 +256,8 @@ type RunDb backend m = ReaderT backend m () -> IO () changeBackend - :: forall backend backend' m. MonadUnliftIO m + :: forall backend backend' m + . (MonadUnliftIO m) => (backend -> backend') -> RunDb backend m -> RunDb backend' m @@ -270,7 +287,7 @@ -- * For implicit ID spec -newtype UUID = UUID { unUUID :: Text } +newtype UUID = UUID {unUUID :: Text} deriving stock (Show, Eq, Ord, Read) deriving newtype @@ -293,7 +310,7 @@ sqlSettingsUuid defExpr = let uuidDef = - mkImplicitIdDef @UUID defExpr + mkImplicitIdDef @UUID defExpr settings = setImplicitIdDef uuidDef sqlSettings in diff --git a/src/LargeNumberTest.hs b/src/LargeNumberTest.hs --- a/src/LargeNumberTest.hs +++ b/src/LargeNumberTest.hs @@ -1,12 +1,15 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} + module LargeNumberTest where import Data.Word import Init -share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "numberMigrate"] [persistLowerCase| +share + [mkPersist sqlSettings{mpsGeneric = True}, mkMigrate "numberMigrate"] + [persistLowerCase| Number intx Int int32 Int32 @@ -17,27 +20,27 @@ |] cleanDB - :: Runner backend m => ReaderT backend m () + :: (Runner backend m) => ReaderT backend m () cleanDB = do - deleteWhere ([] :: [Filter (NumberGeneric backend)]) + deleteWhere ([] :: [Filter (NumberGeneric backend)]) -specsWith :: Runner backend m => RunDb backend m -> Spec +specsWith :: (Runner backend m) => RunDb backend m -> Spec specsWith runDb = describe "Large Numbers" $ do - it "preserves their values in the database" $ runDb $ do - let go x = do - xid <- insert x - x' <- get xid - liftIO $ x' @?= Just x - - go $ Number maxBound 0 0 0 0 - go $ Number 0 maxBound 0 0 0 - go $ Number 0 0 maxBound 0 0 - go $ Number 0 0 0 maxBound 0 - go $ Number 0 0 0 0 maxBound + it "preserves their values in the database" $ runDb $ do + let + go x = do + xid <- insert x + x' <- get xid + liftIO $ x' @?= Just x - go $ Number minBound 0 0 0 0 - go $ Number 0 minBound 0 0 0 - go $ Number 0 0 minBound 0 0 - go $ Number 0 0 0 minBound 0 - go $ Number 0 0 0 0 minBound + go $ Number maxBound 0 0 0 0 + go $ Number 0 maxBound 0 0 0 + go $ Number 0 0 maxBound 0 0 + go $ Number 0 0 0 maxBound 0 + go $ Number 0 0 0 0 maxBound + go $ Number minBound 0 0 0 0 + go $ Number 0 minBound 0 0 0 + go $ Number 0 0 minBound 0 0 + go $ Number 0 0 0 minBound 0 + go $ Number 0 0 0 0 minBound diff --git a/src/LongIdentifierTest.hs b/src/LongIdentifierTest.hs --- a/src/LongIdentifierTest.hs +++ b/src/LongIdentifierTest.hs @@ -11,6 +11,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} + module LongIdentifierTest where import Database.Persist.TH @@ -19,7 +20,9 @@ -- 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"] [persistLowerCase| +share + [mkPersist sqlSettings, mkMigrate "migration"] + [persistLowerCase| TableAnExtremelyFantasticallySuperLongNameParent field1 Int TableAnExtremelyFantasticallySuperLongNameChild @@ -30,9 +33,9 @@ specsWith runDb = describe "Long identifiers" $ do -- See 'refName' in Postgresql.hs for why these tests are necessary. it "migrating is idempotent" $ runDb $ do - again <- getMigration migration - liftIO $ again @?= [] + again <- getMigration migration + liftIO $ again @?= [] it "migrating really is idempotent" $ runDb $ do - runMigration migration - again <- getMigration migration - liftIO $ again @?= [] + runMigration migration + again <- getMigration migration + liftIO $ again @?= [] diff --git a/src/MaxLenTest.hs b/src/MaxLenTest.hs --- a/src/MaxLenTest.hs +++ b/src/MaxLenTest.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-} module MaxLenTest (specsWith, maxlenMigrate) where @@ -8,7 +8,9 @@ import Init -share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "maxlenMigrate"] [persistLowerCase| +share + [mkPersist sqlSettings{mpsGeneric = True}, mkMigrate "maxlenMigrate"] + [persistLowerCase| MaxLen text1 Text text2 Text maxlen=3 @@ -25,22 +27,23 @@ deriving Show Eq |] -specsWith :: Runner backend m => RunDb backend m -> Spec +specsWith :: (Runner backend m) => RunDb backend m -> Spec specsWith runDb = describe "Maximum length attribute" $ do - it "truncates values that are too long" $ runDb $ do - let t1 = MaxLen a a a a a a - t2 = MaxLen b b b b b b - t2' = MaxLen b b' b b' b b' - a, b, b' :: IsString t => t - a = "a" - b = "12345" - b' = "123" - t1k <- insert t1 - t2k <- insert t2 - Just t1v <- get t1k - Just t2v <- get t2k - liftIO $ do t1v @?= t1 - if t2v == t2 - then t2v @?= t2 -- FIXME: why u no truncate? - else t2v @?= t2' - + it "truncates values that are too long" $ runDb $ do + let + t1 = MaxLen a a a a a a + t2 = MaxLen b b b b b b + t2' = MaxLen b b' b b' b b' + a, b, b' :: (IsString t) => t + a = "a" + b = "12345" + b' = "123" + t1k <- insert t1 + t2k <- insert t2 + Just t1v <- get t1k + Just t2v <- get t2k + liftIO $ do + t1v @?= t1 + if t2v == t2 + then t2v @?= t2 -- FIXME: why u no truncate? + else t2v @?= t2' diff --git a/src/MaybeFieldDefsTest.hs b/src/MaybeFieldDefsTest.hs --- a/src/MaybeFieldDefsTest.hs +++ b/src/MaybeFieldDefsTest.hs @@ -9,7 +9,9 @@ import Init -share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "maybeFieldDefMigrate"] [persistLowerCase| +share + [mkPersist sqlSettings{mpsGeneric = True}, mkMigrate "maybeFieldDefMigrate"] + [persistLowerCase| MaybeFieldDefEntity optionalString (Maybe String) optionalInt (Maybe Int) @@ -18,10 +20,10 @@ specsWith :: (Runner backend m) => RunDb backend m -> Spec specsWith runDb = describe "Maybe Field Definitions" $ do - it "runs appropriate migrations" $ runDb $ do - emptyEntity <- insert $ MaybeFieldDefEntity Nothing Nothing - emptyResult <- get emptyEntity - liftIO $ emptyResult @?= Just (MaybeFieldDefEntity Nothing Nothing) - populatedEntity <- insert $ MaybeFieldDefEntity (Just "text") (Just 8) - populatedResult <- get populatedEntity - liftIO $ populatedResult @?= Just (MaybeFieldDefEntity (Just "text") (Just 8)) + it "runs appropriate migrations" $ runDb $ do + emptyEntity <- insert $ MaybeFieldDefEntity Nothing Nothing + emptyResult <- get emptyEntity + liftIO $ emptyResult @?= Just (MaybeFieldDefEntity Nothing Nothing) + populatedEntity <- insert $ MaybeFieldDefEntity (Just "text") (Just 8) + populatedResult <- get populatedEntity + liftIO $ populatedResult @?= Just (MaybeFieldDefEntity (Just "text") (Just 8)) diff --git a/src/MigrationColumnLengthTest.hs b/src/MigrationColumnLengthTest.hs --- a/src/MigrationColumnLengthTest.hs +++ b/src/MigrationColumnLengthTest.hs @@ -1,20 +1,23 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} + module MigrationColumnLengthTest where import qualified Data.Text as T import Init -share [mkPersist sqlSettings, mkMigrate "migration"] [persistLowerCase| +share + [mkPersist sqlSettings, mkMigrate "migration"] + [persistLowerCase| VaryingLengths field1 Int field2 T.Text sqltype=varchar(5) |] -specsWith :: MonadIO m => RunDb SqlBackend m -> Spec +specsWith :: (MonadIO m) => RunDb SqlBackend m -> Spec specsWith runDb = - it "is idempotent" $ runDb $ do - again <- getMigration migration - liftIO $ again @?= [] + it "is idempotent" $ runDb $ do + again <- getMigration migration + liftIO $ again @?= [] diff --git a/src/MigrationIdempotencyTest.hs b/src/MigrationIdempotencyTest.hs --- a/src/MigrationIdempotencyTest.hs +++ b/src/MigrationIdempotencyTest.hs @@ -1,6 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} + module MigrationIdempotencyTest where import Data.Int (Int32, Int64) @@ -9,7 +10,9 @@ import Database.Persist.TH import Init -share [mkPersist sqlSettings, mkMigrate "migration"] [persistLowerCase| +share + [mkPersist sqlSettings, mkMigrate "migration"] + [persistLowerCase| Idempotency field1 Int64 field2 T.Text sqltype=varchar(5) @@ -24,6 +27,6 @@ specsWith :: (MonadIO m) => RunDb SqlBackend m -> Spec specsWith runDb = describe "MySQL migration with backend-specific sqltypes" $ do - it "is idempotent" $ runDb $ do - again <- getMigration migration - liftIO $ again @?= [] + it "is idempotent" $ runDb $ do + again <- getMigration migration + liftIO $ again @?= [] diff --git a/src/MigrationOnlyTest.hs b/src/MigrationOnlyTest.hs --- a/src/MigrationOnlyTest.hs +++ b/src/MigrationOnlyTest.hs @@ -1,16 +1,19 @@ -{-# LANGUAGE TypeApplications, TypeOperators, UndecidableInstances #-} - +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-} module MigrationOnlyTest (specsWith, migrateAll1, migrateAll2) where import qualified Data.Text as T +import Database.Persist.EntityDef import Database.Persist.TH import Init -import Database.Persist.EntityDef -share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "migrateAll1"] [persistLowerCase| +share + [mkPersist sqlSettings{mpsGeneric = True}, mkMigrate "migrateAll1"] + [persistLowerCase| TwoField1 sql=two_field field1 Int field2 T.Text @@ -18,7 +21,9 @@ deriving Eq Show |] -share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "migrateAll2"] [persistLowerCase| +share + [mkPersist sqlSettings{mpsGeneric = True}, mkMigrate "migrateAll2"] + [persistLowerCase| TwoField field1 Int field2 T.Text @@ -31,7 +36,11 @@ |] specsWith - :: (MonadIO m, PersistQueryWrite backend, PersistStoreWrite backend, PersistQueryWrite (BaseBackend backend)) + :: ( MonadIO m + , PersistQueryWrite backend + , PersistStoreWrite backend + , PersistQueryWrite (BaseBackend backend) + ) => RunDb backend m -> Maybe (ReaderT backend m a) -> Spec @@ -60,7 +69,8 @@ it "doesn't have the field in the Haskell entity" $ asIO $ runDb $ do sequence_ mmigrate sequence_ mmigrate - let tf = TwoField 5 "hello" + let + tf = TwoField 5 "hello" tid <- insert tf mtf <- get tid liftIO $ mtf @?= Just tf diff --git a/src/MigrationTest.hs b/src/MigrationTest.hs --- a/src/MigrationTest.hs +++ b/src/MigrationTest.hs @@ -1,14 +1,17 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} + module MigrationTest where -import Database.Persist.TH import qualified Data.Text as T +import Database.Persist.TH import Init -share [mkPersist sqlSettings, mkMigrate "migrationMigrate"] [persistLowerCase| +share + [mkPersist sqlSettings, mkMigrate "migrationMigrate"] + [persistLowerCase| Target field1 Int field2 T.Text @@ -24,7 +27,9 @@ Primary pk |] -share [mkPersist sqlSettings, mkMigrate "migrationAddCol"] [persistLowerCase| +share + [mkPersist sqlSettings, mkMigrate "migrationAddCol"] + [persistLowerCase| Target1 sql=target field1 Int field2 T.Text @@ -40,17 +45,17 @@ specsWith :: (MonadUnliftIO m) => RunDb SqlBackend m -> Spec specsWith runDb = describe "Migration" $ do it "is idempotent" $ runDb $ do - again <- getMigration migrationMigrate - liftIO $ again @?= [] + again <- getMigration migrationMigrate + liftIO $ again @?= [] it "really is idempotent" $ runDb $ do - void $ runMigrationSilent migrationMigrate - void $ runMigrationSilent migrationMigrate - again <- getMigration migrationMigrate - liftIO $ again @?= [] + 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. - void $ runMigrationSilent migrationAddCol - again <- getMigration migrationAddCol - liftIO $ again @?= [] + -- 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. + void $ runMigrationSilent migrationAddCol + again <- getMigration migrationAddCol + liftIO $ again @?= [] diff --git a/src/MpsCustomPrefixTest.hs b/src/MpsCustomPrefixTest.hs --- a/src/MpsCustomPrefixTest.hs +++ b/src/MpsCustomPrefixTest.hs @@ -3,30 +3,31 @@ import Init import PersistentTestModels -specsWith :: MonadIO m => RunDb SqlBackend m -> Spec +specsWith :: (MonadIO m) => RunDb SqlBackend m -> Spec specsWith runDb = describe "mpsCustomPrefix" $ - it "works" $ runDb $ do - deleteWhere ([] :: [Filter CustomPrefix2]) - deleteWhere ([] :: [Filter CustomPrefix1]) - cp1a <- insert $ CustomPrefix1 1 - update cp1a [CP1CustomFieldName =. 2] - cp1b <- insert $ CustomPrefix1 3 - cp2 <- insert $ CustomPrefix2 4 cp1a - update cp2 [CP2CustomPrefixedRef =. cp1b, CP2OtherCustomFieldName =. 5] + it "works" $ + runDb $ do + deleteWhere ([] :: [Filter CustomPrefix2]) + deleteWhere ([] :: [Filter CustomPrefix1]) + cp1a <- insert $ CustomPrefix1 1 + update cp1a [CP1CustomFieldName =. 2] + cp1b <- insert $ CustomPrefix1 3 + cp2 <- insert $ CustomPrefix2 4 cp1a + update cp2 [CP2CustomPrefixedRef =. cp1b, CP2OtherCustomFieldName =. 5] - mcp1a <- get cp1a - liftIO $ mcp1a @?= Just (CustomPrefix1 2) - liftIO $ fmap _cp1CustomFieldName mcp1a @?= Just 2 - mcp2 <- get cp2 - liftIO $ fmap _cp2CustomPrefixedRef mcp2 @?= Just cp1b - liftIO $ fmap _cp2OtherCustomFieldName mcp2 @?= Just 5 + mcp1a <- get cp1a + liftIO $ mcp1a @?= Just (CustomPrefix1 2) + liftIO $ fmap _cp1CustomFieldName mcp1a @?= Just 2 + mcp2 <- get cp2 + liftIO $ fmap _cp2CustomPrefixedRef mcp2 @?= Just cp1b + liftIO $ fmap _cp2OtherCustomFieldName mcp2 @?= Just 5 - cpls <- insert $ CPCustomPrefixedLeftSum 5 - cprs <- insert $ CPCustomPrefixedRightSum "Hello" - update cpls [CPCustomPrefixedLeft =. 6] - update cprs [CPCustomPrefixedRight =. "World"] - mcpls <- get cpls - mcprs <- get cprs + cpls <- insert $ CPCustomPrefixedLeftSum 5 + cprs <- insert $ CPCustomPrefixedRightSum "Hello" + update cpls [CPCustomPrefixedLeft =. 6] + update cprs [CPCustomPrefixedRight =. "World"] + mcpls <- get cpls + mcprs <- get cprs - liftIO $ mcpls @?= Just (CPCustomPrefixedLeftSum 6) - liftIO $ mcprs @?= Just (CPCustomPrefixedRightSum "World") + liftIO $ mcpls @?= Just (CPCustomPrefixedLeftSum 6) + liftIO $ mcprs @?= Just (CPCustomPrefixedRightSum "World") diff --git a/src/MpsNoPrefixTest.hs b/src/MpsNoPrefixTest.hs --- a/src/MpsNoPrefixTest.hs +++ b/src/MpsNoPrefixTest.hs @@ -3,30 +3,31 @@ import Init import PersistentTestModels -specsWith :: MonadIO m => RunDb SqlBackend m -> Spec +specsWith :: (MonadIO m) => RunDb SqlBackend m -> Spec specsWith runDb = describe "mpsNoPrefix" $ do - it "works" $ runDb $ do - deleteWhere ([] :: [Filter NoPrefix2]) - deleteWhere ([] :: [Filter NoPrefix1]) - np1a <- insert $ NoPrefix1 1 - update np1a [SomeFieldName =. 2] - np1b <- insert $ NoPrefix1 3 - np2 <- insert $ NoPrefix2 4 np1a - update np2 [UnprefixedRef =. np1b, SomeOtherFieldName =. 5] + it "works" $ runDb $ do + deleteWhere ([] :: [Filter NoPrefix2]) + deleteWhere ([] :: [Filter NoPrefix1]) + np1a <- insert $ NoPrefix1 1 + update np1a [SomeFieldName =. 2] + np1b <- insert $ NoPrefix1 3 + np2 <- insert $ NoPrefix2 4 np1a + update np2 [UnprefixedRef =. np1b, SomeOtherFieldName =. 5] - mnp1a <- get np1a - liftIO $ mnp1a @?= Just (NoPrefix1 2) - liftIO $ fmap someFieldName mnp1a @?= Just 2 - mnp2 <- get np2 - liftIO $ fmap unprefixedRef mnp2 @?= Just np1b - liftIO $ fmap someOtherFieldName mnp2 @?= Just 5 + mnp1a <- get np1a + liftIO $ mnp1a @?= Just (NoPrefix1 2) + liftIO $ fmap someFieldName mnp1a @?= Just 2 + mnp2 <- get np2 + liftIO $ fmap unprefixedRef mnp2 @?= Just np1b + liftIO $ fmap someOtherFieldName mnp2 @?= Just 5 - insert_ $ UnprefixedLeftSum 5 - insert_ $ UnprefixedRightSum "Hello" + insert_ $ UnprefixedLeftSum 5 + insert_ $ UnprefixedRightSum "Hello" - it "IsSqlKey instance" $ runDb $ do - let p = Person "Alice" 30 Nothing - key@(PersonKey (SqlBackendKey i)) <- insert p - liftIO $ fromSqlKey key `shouldBe` (i :: Int64) - mp <- get $ toSqlKey i - liftIO $ mp `shouldBe` Just p + it "IsSqlKey instance" $ runDb $ do + let + p = Person "Alice" 30 Nothing + key@(PersonKey (SqlBackendKey i)) <- insert p + liftIO $ fromSqlKey key `shouldBe` (i :: Int64) + mp <- get $ toSqlKey i + liftIO $ mp `shouldBe` Just p diff --git a/src/PersistTestPetCollarType.hs b/src/PersistTestPetCollarType.hs --- a/src/PersistTestPetCollarType.hs +++ b/src/PersistTestPetCollarType.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} + module PersistTestPetCollarType where import Data.Aeson diff --git a/src/PersistUniqueTest.hs b/src/PersistUniqueTest.hs --- a/src/PersistUniqueTest.hs +++ b/src/PersistUniqueTest.hs @@ -1,12 +1,15 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} + module PersistUniqueTest where 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 "migration"] [persistLowerCase| +share + [mkPersist persistSettings{mpsGeneric = False}, mkMigrate "migration"] + [persistLowerCase| Fo foo Int @@ -35,92 +38,109 @@ deriving stock instance Show (Unique Ba) deriving stock instance Eq (Unique Ba) -shouldCompile :: (OnlyOneUniqueKey OnlyPrimaryKey, AtLeastOneUniqueKey OnlyPrimaryKey) => IO () +shouldCompile + :: (OnlyOneUniqueKey OnlyPrimaryKey, AtLeastOneUniqueKey OnlyPrimaryKey) => IO () shouldCompile = pure () -cleanDB :: (MonadIO m, PersistQuery backend, PersistEntityBackend Fo ~ backend) => ReaderT backend m () +cleanDB + :: (MonadIO m, PersistQuery backend, PersistEntityBackend Fo ~ backend) + => ReaderT backend m () cleanDB = do - deleteWhere ([] :: [Filter Fo]) + deleteWhere ([] :: [Filter Fo]) -specsWith :: Runner SqlBackend m => RunDb SqlBackend m -> Spec +specsWith :: (Runner SqlBackend m) => RunDb SqlBackend m -> Spec 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 } + let + b = 5 + k <- insert Fo{foFoo = 3, foBar = b} Just vk <- get k Just vu <- getBy (UniqueBar b) vu @== Entity k vk describe "existsBy" $ do it "works to query the existence of a record in the database" $ runDb $ do - let b = 5 - k <- insert Fo { foFoo = 3, foBar = b } + let + b = 5 + k <- insert Fo{foFoo = 3, foBar = b} result <- existsBy $ UniqueBar b result @== True it "returns false for nonexistent records" $ runDb $ do - insert_ Fo { foFoo = 3, foBar = 5 } + insert_ Fo{foFoo = 3, foBar = 5} result <- existsBy $ UniqueBar 17 result @== False describe "insertUniqueEntity" $ do it "inserts a value if no conflicts are present" $ runDb $ do - let fo = Fo 3 5 + let + fo = Fo 3 5 Just (Entity _ insertedFoValue) <- insertUniqueEntity fo fo @== insertedFoValue it "does not insert if the record is entirely the same" $ runDb $ do - let fo = Fo 3 5 + 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 + let + fo = Fo 3 5 Just (Entity _ insertedFoValue) <- insertUniqueEntity fo - mresult <- insertUniqueEntity fo { foFoo = 4 } + 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 + let + fo = Fo 3 5 Just (Entity _ insertedFoValue) <- insertUniqueEntity fo - mresult <- insertUniqueEntity fo { foBar = 4 } + 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 } + 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 } + 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 + 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 + 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 + 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) + 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)) @@ -137,7 +157,7 @@ entity <- upsert record [OnlyPrimaryKeyName =. "Hello"] entityVal entity @== record entity' <- upsert record [OnlyPrimaryKeyName =. "Hello"] - entityVal entity' @== record { onlyPrimaryKeyName = "Hello" } + entityVal entity' @== record{onlyPrimaryKeyName = "Hello"} describe "Fo" $ do it "cannot upsert" $ runDb $ do @@ -145,13 +165,13 @@ -- _ <- upsert Fo { foFoo = 1, foBar = 2 } [FoFoo +=. 1] pure () it "can upsertBy" $ runDb $ do - let f = Fo { foFoo = 1, foBar = 2 } + 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 } + entityVal entity' @== f{foBar = 1 + foBar f} describe "OnlyPrimaryKey" $ do it "has unique constraints" $ do shouldCompile - diff --git a/src/PersistentTest.hs b/src/PersistentTest.hs --- a/src/PersistentTest.hs +++ b/src/PersistentTest.hs @@ -1,659 +1,759 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE RecordWildCards, UndecidableInstances #-} - -module PersistentTest - ( module PersistentTest - , cleanDB - , testMigrate - , noPrefixMigrate - , customPrefixMigrate - , treeMigrate - ) where - -import Control.Monad.Fail -import Control.Monad.IO.Class -import Data.Aeson -import Data.Conduit -import qualified Data.Conduit.List as CL -import Data.Functor.Constant -import Data.Functor.Identity -import qualified Data.Map as Map -import Data.Maybe (fromJust) -import Test.Hspec.QuickCheck(prop) -import Test.HUnit hiding (Test) -import UnliftIO (MonadUnliftIO, catch) -import Web.PathPieces (PathPiece (..)) -import Data.Proxy (Proxy(..)) - -import Database.Persist -import Init -import PersistentTestModels -import PersistTestPetType -import PersistTestPetCollarType - -catchPersistException :: (MonadUnliftIO m, MonadFail m) => m a -> b -> m b -catchPersistException action errValue = do - Left res <- - (Right `fmap` action) `catch` - (\(_::PersistException) -> return $ Left errValue) - return res - -filterOrSpecs - :: forall m backend. Runner backend m - => RunDb backend m - -> Spec -filterOrSpecs runDb = describe "FilterOr" $ do - it "FilterOr []" $ runDb $ do - let p = Person "z" 1 Nothing - insert_ p - ps <- selectList [FilterOr []] [Desc PersonAge] - assertEmpty ps - it "||. []" $ runDb $ do - let p = Person "z" 1 Nothing - insert_ p - c <- count $ [PersonName ==. "a"] ||. [] - c @== (1::Int) - --- Test proper polymorphism -_polymorphic :: (MonadFail m, MonadIO m, PersistQuery backend, BaseBackend backend ~ PersistEntityBackend Pet) => ReaderT backend m () -_polymorphic = do - ((Entity id' _):_) <- selectList [] [LimitTo 1] - _ <- selectList [PetOwnerId ==. id'] [] - insert_ $ Pet id' "foo" Cat - return () - --- Some lens stuff -type ASetter s t a b = (a -> Identity b) -> s -> Identity t - -set :: ASetter s t a b -> b -> s -> t -set l b = runIdentity . (l (\_ -> Identity b)) - -type Getting r s t a b = (a -> Constant r b) -> s -> Constant r t - -view :: s -> Getting a s t a b -> a -view s l = getConstant (l Constant s) - -safeToRemoveSpec :: forall backend m. Runner backend m => RunDb backend m -> Spec -safeToRemoveSpec runDb = do - describe "DudeWeirdColumns" $ do - it "can insert and get" $ do - let m = DudeWeirdColumns "hello" - runDb $ do - k <- insert m - mval <- get k - liftIO $ fmap dudeWeirdColumnsName mval `shouldBe` Just "hello" - it "can putMany" $ do - let ms = - [ DudeWeirdColumns "hello" - , DudeWeirdColumns "goodbyue" - ] - runDb $ putMany ms - -specsWith :: forall backend m. Runner backend m => RunDb backend m -> Spec -specsWith runDb = describe "persistent" $ do - describe "SafeToRemove" (safeToRemoveSpec runDb) - it "fieldLens" $ do - let michael = Entity undefined $ Person "Michael" 28 Nothing :: Entity Person - michaelP1 = Person "Michael" 29 Nothing :: Person - view michael (fieldLens PersonAge) @?= 28 - entityVal (set (fieldLens PersonAge) 29 michael) @?= michaelP1 - - it "FilterAnd []" $ runDb $ do - let p = Person "z" 1 Nothing - insert_ p - ps <- selectList [FilterAnd []] [Desc PersonAge] - assertNotEmpty ps - - it "Filter In" $ runDb $ do - _ <- selectList [Filter PersonName (FilterValues ["Kostas"]) In] [] - return () - - it "order of opts is irrelevant" $ runDb $ do - let eq (a, b, _) (c, d) = (a, b) @== (c, d) - limitOffsetOrder' :: [SelectOpt Person] -> (Int, Int, [SelectOpt Person]) - limitOffsetOrder' = limitOffsetOrder - limitOffsetOrder' [Desc PersonAge] `eq` (0, 0) - limitOffsetOrder' [LimitTo 2, Desc PersonAge] `eq` (2, 0) - limitOffsetOrder' [Desc PersonAge, LimitTo 2] `eq` (2, 0) - limitOffsetOrder' [LimitTo 2, Desc PersonAge, OffsetBy 3] `eq` (2, 3) - - insertMany_ [ Person "z" 1 Nothing - , Person "y" 2 Nothing - , Person "x" 1 Nothing - , Person "w" 2 Nothing - , Person "v" 1 Nothing - , Person "u" 2 Nothing - ] - - a <- map (personName . entityVal) <$> selectList [] [Desc PersonAge, Asc PersonName, OffsetBy 2, LimitTo 3] - a @== ["y", "v", "x"] - - b <- map (personName . entityVal) <$> selectList [] [OffsetBy 2, Desc PersonAge, LimitTo 3, Asc PersonName] - b @== a - - c <- map (personName . entityVal) <$> selectList [] [OffsetBy 2, Desc PersonAge, LimitTo 3, Asc PersonName, LimitTo 1, OffsetBy 1] - c @== a - - - it "passes the general tests" $ runDb $ do - let mic26 = Person "Michael" 26 Nothing - micK <- insert mic26 - results <- selectList [PersonName ==. "Michael"] [] - results @== [Entity micK mic26] - - results' <- selectList [PersonAge <. 28] [] - results' @== [Entity micK mic26] - - p28 <- updateGet micK [PersonAge =. 28] - personAge p28 @== 28 - - updateWhere [PersonName ==. "Michael"] [PersonAge =. 29] - uc <- count [PersonName ==. "Michael"] - uc @== 1 - 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 - pasc <- selectList [] [Asc PersonAge] - map entityVal pasc @== [eli, mic29] - - let abe30 = Person "Abe" 30 $ Just "black" - insert_ abe30 - -- pdesc <- selectList [PersonAge <. 30] [Desc PersonName] - map entityVal pasc @== [eli, mic29] - - abes <- selectList [PersonName ==. "Abe"] [] - map entityVal abes @== [abe30] - - Just (Entity _ p3) <- getBy $ PersonNameKey "Michael" - p3 @== mic29 - - ps <- selectList [PersonColor ==. Just "blue"] [] - map entityVal ps @== [eli] - - ps2 <- selectList [PersonColor ==. Nothing] [] - map entityVal ps2 @== [mic29] - - delete micK - Nothing <- get micK - return () - it "persistIdField" $ runDb $ do - let p = Person "foo" 100 (Just "blue") - q = Person "bar" 101 Nothing - pk <- insert p - qk <- insert q - - mp <- selectFirst [persistIdField ==. pk] [] - fmap entityVal mp @== Just p - - mq <- selectFirst [persistIdField ==. qk] [] - fmap entityVal mq @== Just q - - it "!=." $ runDb $ do - deleteWhere ([] :: [Filter (PersonGeneric backend)]) - let mic = Person "Michael" 25 Nothing - insert_ mic - let eli = Person "Eliezer" 25 (Just "Red") - insert_ eli - - pne <- selectList [PersonName !=. "Michael"] [] - map entityVal pne @== [eli] - - ps <- selectList [PersonColor !=. Nothing] [] - map entityVal ps @== [eli] - - pnm <- selectList [PersonName !=. "Eliezer"] [] - map entityVal pnm @== [mic] - - - it "Double Maybe" $ runDb $ do - deleteWhere ([] :: [Filter (PersonMayGeneric backend)]) - let mic = PersonMay (Just "Michael") Nothing - insert_ mic - let eli = PersonMay (Just "Eliezer") (Just "Red") - insert_ eli - pe <- selectList [PersonMayName ==. Nothing, PersonMayColor ==. Nothing] [] - map entityVal pe @== [] - pne <- selectList [PersonMayName !=. Nothing, PersonMayColor !=. Nothing] [] - map entityVal pne @== [eli] - - it "and/or" $ runDb $ do - deleteWhere ([] :: [Filter (Person1Generic backend)]) - insertMany_ [ Person1 "Michael" 25 - , Person1 "Miriam" 25 - , Person1 "Michael" 30 - , Person1 "Michael" 35 - ] - - c10 <- count $ [Person1Name ==. "Michael"] ||. [Person1Name ==. "Miriam", Person1Age ==. 25] - c10 @== 4 - c12 <- count [FilterOr [FilterAnd [Person1Name ==. "Michael"], FilterAnd [Person1Name ==. "Miriam"]]] - c12 @== 4 - c14 <- count [FilterOr [FilterAnd [Person1Name ==. "Michael"], FilterAnd [Person1Name ==. "Miriam"], - FilterAnd [Person1Age >. 29, Person1Age <=. 30]]] - c14 @== 4 - - c20 <- count $ [Person1Name ==. "Miriam"] ||. [Person1Age >. 29, Person1Age <=. 30] - c20 @== 2 - c22 <- count $ [Person1Age <=. 30] ++ [Person1Age >. 29] - c22 @== 1 - c24 <- count $ [FilterAnd [Person1Age <=. 30, Person1Age >. 29]] - c24 @== 1 - c26 <- count $ [Person1Age <=. 30] ++ [Person1Age >. 29] - c26 @== 1 - - c34 <- count $ [Person1Name ==. "Michael"] ||. [Person1Name ==. "Mirieam"] ++ [Person1Age <.35] - c34 @== 3 - c30 <- count $ ([Person1Name ==. "Michael"] ||. [Person1Name ==. "Miriam"]) ++ [Person1Age <.35] - c30 @== 3 - c36 <- count $ [Person1Name ==. "Michael"] ||. ([Person1Name ==. "Miriam"] ++ [Person1Age <.35]) - c36 @== 4 - - c40 <- count $ ([Person1Name ==. "Michael"] ||. [Person1Name ==. "Miriam"] ||. [Person1Age <.35]) - c40 @== 4 - - - it "deleteWhere" $ runDb $ do - key2 <- insert $ Person "Michael2" 90 Nothing - _ <- insert $ Person "Michael3" 90 Nothing - let p91 = Person "Michael4" 91 Nothing - key91 <- insert p91 - - ps90 <- selectList [PersonAge ==. 90] [] - assertNotEmpty ps90 - deleteWhere [PersonAge ==. 90] - ps90' <- selectList [PersonAge ==. 90] [] - assertEmpty ps90' - Nothing <- get key2 - - Just p2_91 <- get key91 - p91 @== p2_91 - - - it "deleteBy" $ runDb $ do - insert_ $ Person "Michael2" 27 Nothing - let p3 = Person "Michael3" 27 Nothing - key3 <- insert p3 - - ps2 <- selectList [PersonName ==. "Michael2"] [] - assertNotEmpty ps2 - - deleteBy $ PersonNameKey "Michael2" - ps2' <- selectList [PersonName ==. "Michael2"] [] - assertEmpty ps2' - - Just p32 <- get key3 - p3 @== p32 - - - it "delete" $ runDb $ do - key2 <- insert $ Person "Michael2" 27 Nothing - let p3 = Person "Michael3" 27 Nothing - key3 <- insert p3 - - pm2 <- selectList [PersonName ==. "Michael2"] [] - assertNotEmpty pm2 - delete key2 - pm2' <- selectList [PersonName ==. "Michael2"] [] - assertEmpty pm2' - - Just p <- get key3 - p3 @== p - - prop "toPathPiece . fromPathPiece" $ \piece -> - let key1 = piece :: (BackendKey SqlBackend) - key2 = fromJust $ fromPathPiece $ toPathPiece key1 :: (BackendKey SqlBackend) - in toPathPiece key1 == toPathPiece key2 - - it "replace" $ runDb $ do - key2 <- insert $ Person "Michael2" 27 Nothing - let p3 = Person "Michael3" 27 Nothing - replace key2 p3 - Just p <- get key2 - p @== p3 - - -- test replace an empty key - delete key2 - Nothing <- get key2 - _ <- replace key2 p3 - Nothing <- get key2 - return () - - let mic = Person "Michael" 25 Nothing - micK <- insert mic - Just p1 <- get micK - p1 @== mic - - replace micK $ Person "Michael" 25 Nothing - Just p2 <- get micK - p2 @== mic - - replace micK $ Person "Michael" 26 Nothing - Just mic26 <- get micK - mic26 @/= mic - personAge mic26 @== personAge mic + 1 - - - - it "getBy" $ runDb $ do - let p2 = Person "Michael2" 27 Nothing - key2 <- insert p2 - Just (Entity k p) <- getBy $ PersonNameKey "Michael2" - p @== p2 - k @== key2 - Nothing <- getBy $ PersonNameKey "Michael9" - - Just (Entity k' p') <- getByValue p2 - k' @== k - p' @== p - return () - - - it "updateGet" $ runDb $ do - let p25 = Person "Michael" 25 Nothing - key25 <- insert p25 - pBlue28 <- updateGet key25 [PersonAge =. 28, PersonName =. "Updated"] - pBlue28 @== Person "Updated" 28 Nothing - pBlue30 <- updateGet key25 [PersonAge +=. 2] - pBlue30 @== Person "Updated" 30 Nothing - - describe "repsertMany" $ do - it "adds new rows when no conflicts" $ runDb $ do - ids@[johnId, janeId, aliceId, eveId] <- replicateM 4 $ liftIO (Person1Key `fmap` generateKey) - let john = Person1 "john" 20 - let jane = Person1 "jane" 18 - let alice = Person1 "alice" 18 - let eve = Person1 "eve" 19 - - insertKey johnId john - insertKey janeId jane - - _ <- repsertMany [ (aliceId, alice), (eveId, eve) ] - es <- getMany ids - - let rs = [john, jane, alice, eve] - es @== Map.fromList (zip ids rs) - mapM_ delete ids - - it "handles conflicts by replacing old keys with new records" $ runDb $ do - let john = Person1 "john" 20 - let jane = Person1 "jane" 18 - let alice = Person1 "alice" 18 - let eve = Person1 "eve" 19 - - johnId <- insert john - janeId <- insert jane - - _ <- repsertMany [ (johnId, alice), (janeId, eve) ] - (Just alice') <- get johnId - (Just eve') <- get janeId - - [alice',eve'] @== [alice,eve] - mapM_ delete [johnId, janeId] - - it "updateWhere" $ runDb $ do - let p1 = Person "Michael" 25 Nothing - let p2 = Person "Michael2" 25 Nothing - key1 <- insert p1 - key2 <- insert p2 - updateWhere [PersonName ==. "Michael2"] - [PersonAge +=. 3, PersonName =. "Updated"] - Just pBlue28 <- get key2 - pBlue28 @== Person "Updated" 28 Nothing - Just p <- get key1 - p @== p1 - - it "selectList" $ runDb $ do - let p25 = Person "Michael" 25 Nothing - let p26 = Person "Michael2" 26 Nothing - [key25, key26] <- insertMany [p25, p26] - ps1 <- selectList [] [Asc PersonAge] - ps1 @== [(Entity key25 p25), (Entity key26 p26)] - -- limit - ps2 <- selectList [] [Asc PersonAge, LimitTo 1] - ps2 @== [(Entity key25 p25)] - -- offset - ps3 <- selectList [] [Asc PersonAge, OffsetBy 1] - ps3 @== [(Entity key26 p26)] - -- limit & offset - ps4 <- selectList [] [Asc PersonAge, LimitTo 1, OffsetBy 1] - ps4 @== [(Entity key26 p26)] - - ps5 <- selectList [] [Desc PersonAge] - ps5 @== [(Entity key26 p26), (Entity key25 p25)] - ps6 <- selectList [PersonAge ==. 26] [] - ps6 @== [(Entity key26 p26)] - - it "selectSource" $ runDb $ do - let p1 = Person "selectSource1" 1 Nothing - p2 = Person "selectSource2" 2 Nothing - p3 = Person "selectSource3" 3 Nothing - [k1,k2,k3] <- insertMany [p1, p2, p3] - - ps1 <- runConduitRes $ selectSource [] [Desc PersonAge] .| await - ps1 @== Just (Entity k3 p3) - - ps2 <- runConduitRes $ selectSource [PersonAge <. 3] [Asc PersonAge] .| CL.consume - ps2 @== [Entity k1 p1, Entity k2 p2] - - runConduitRes $ selectSource [] [Desc PersonAge] .| do - e1 <- await - e1 @== Just (Entity k3 p3) - - e2 <- await - e2 @== Just (Entity k2 p2) - - e3 <- await - e3 @== Just (Entity k1 p1) - - e4 <- await - e4 @== Nothing - - it "selectFirst" $ runDb $ do - insert_ $ Person "Michael" 26 Nothing - let pOld = Person "Oldie" 75 Nothing - kOld <- insert pOld - - x <- selectFirst [] [Desc PersonAge] - x @== Just (Entity kOld pOld) - - - it "selectKeys" $ runDb $ do - let p1 = Person "selectKeys1" 1 Nothing - p2 = Person "selectKeys2" 2 Nothing - p3 = Person "selectKeys3" 3 Nothing - [k1,k2,k3] <- insertMany [p1, p2, p3] - - ps1 <- runConduitRes $ selectKeys [] [Desc PersonAge] .| await - ps1 @== Just k3 - - ps2 <- runConduitRes $ selectKeys [PersonAge <. 3] [Asc PersonAge] .| CL.consume - ps2 @== [k1, k2] - - runConduitRes $ selectKeys [] [Desc PersonAge] .| do - e1 <- await - e1 @== Just k3 - - e2 <- await - e2 @== Just k2 - - e3 <- await - e3 @== Just k1 - - e4 <- await - e4 @== Nothing - - it "insertMany_ with no arguments" $ runDb $ do - _ <- insertMany_ ([] :: [PersonGeneric backend]) - rows <- (count ([] :: [Filter (PersonGeneric backend)]) :: ReaderT backend m Int) - rows @== 0 - _ <- insertMany ([] :: [PersonGeneric backend]) - rows2 <- count ([] :: [Filter (PersonGeneric backend)]) - rows2 @== 0 - _ <- insertEntityMany ([] :: [Entity (PersonGeneric backend)]) - rows3 <- count ([] :: [Filter (PersonGeneric backend)]) - rows3 @== 0 - - it "insertEntityMany" $ runDb $ do - id1:id2:id3:id4:id5:[] <- liftIO $ replicateM 5 (PersonKey `fmap` generateKey) - let p1 = Entity id1 $ Person "insertEntityMany1" 1 Nothing - p2 = Entity id2 $ Person "insertEntityMany2" 2 Nothing - p3 = Entity id3 $ Person "insertEntityMany3" 3 Nothing - p4 = Entity id4 $ Person "insertEntityMany4" 3 Nothing - p5 = Entity id5 $ Person "insertEntityMany5" 3 Nothing - insertEntityMany [p1,p2,p3,p4,p5] - rows <- count ([] :: [Filter (PersonGeneric backend)]) - rows @== 5 - - it "insertBy" $ runDb $ do - Right _ <- insertBy $ Person "name" 1 Nothing - Left _ <- insertBy $ Person "name" 1 Nothing - Right _ <- insertBy $ Person "name2" 1 Nothing - return () - - it "insertKey" $ runDb $ do - k <- liftIO (PersonKey `fmap` generateKey) - insertKey k $ Person "Key" 26 Nothing - Just (Entity k2 _) <- selectFirst [PersonName ==. "Key"] [] - k2 @== k - - it "insertEntity" $ runDb $ do - Entity k p <- insertEntity $ Person "name" 1 Nothing - Just p2 <- get k - p2 @== p - - it "insertRecord" $ runDb $ do - let record = Person "name" 1 Nothing - record' <- insertRecord record - record' @== record - - it "getEntity" $ runDb $ do - Entity k p <- insertEntity $ Person "name" 1 Nothing - Just (Entity k2 p2) <- getEntity k - p @== p2 - k @== k2 - - it "getJustEntity" $ runDb $ do - let p1 = Person "name" 1 Nothing - k1 <- insert p1 - Entity k2 p2 <- getJustEntity k1 - p1 @== p2 - k1 @== k2 - - it "repsert" $ runDb $ do - k <- liftIO (PersonKey `fmap` generateKey) - Nothing <- selectFirst [PersonName ==. "Repsert"] [] - repsert k $ Person "Repsert" 26 Nothing - Just (Entity k2 _) <- selectFirst [PersonName ==. "Repsert"] [] - k2 @== k - repsert k $ Person "Repsert" 27 Nothing - Just (Entity k3 p) <- selectFirst [PersonName ==. "Repsert"] [] - k3 @== k - 27 @== personAge p - - it "retrieves a belongsToJust association" $ runDb $ do - let p = Person "pet owner" 30 Nothing - person <- insert p - let cat = Pet person "Mittens" Cat - p2 <- getJust $ petOwnerId cat - p @== p2 - p3 <- belongsToJust petOwnerId cat - p @== p3 - - it "retrieves a belongsTo association" $ runDb $ do - let p = Person "pet owner" 30 Nothing - person <- insert p - let cat = MaybeOwnedPet (Just person) "Mittens" Cat - p2 <- getJust $ fromJust $ maybeOwnedPetOwnerId cat - p @== p2 - Just p4 <- belongsTo maybeOwnedPetOwnerId cat - p @== p4 - - it "derivePersistField" $ runDb $ do - person <- insert $ Person "pet owner" 30 Nothing - catKey <- insert $ Pet person "Mittens" Cat - Just cat' <- get catKey - liftIO $ petType cat' @?= Cat - dog <- insert $ Pet person "Spike" Dog - Just dog' <- get dog - liftIO $ petType dog' @?= Dog - - it "derivePersistFieldJSON" $ runDb $ do - let mittensCollar = PetCollar "Mittens\n1-714-668-9672" True - pkey <- insert $ Person "pet owner" 30 Nothing - catKey <- insert $ OutdoorPet pkey mittensCollar Cat - Just (OutdoorPet _ collar' _) <- get catKey - liftIO $ collar' @?= mittensCollar - - it "idIn" $ runDb $ do - let p1 = Person "D" 0 Nothing - p2 = Person "E" 1 Nothing - p3 = Person "F" 2 Nothing - pid1 <- insert p1 - insert_ p2 - pid3 <- insert p3 - x <- selectList [PersonId <-. [pid1, pid3]] [] - liftIO $ x @?= [Entity pid1 p1, Entity pid3 p3] - - it "In" $ runDb $ do - let p1 = Person "D" 0 Nothing - p2 = Person "E" 1 Nothing - p3 = Person "F" 2 (Just "blue") - insert_ p1 - insert_ p2 - insert_ p3 - x1 <- fmap entityVal `fmap` selectList [PersonName <-. ["D"]] [] - liftIO $ x1 @?= [p1] - x2 <- fmap entityVal `fmap` selectList [PersonName /<-. ["D"]] [] - liftIO $ x2 @?= [p2, p3] - - x3 <- fmap entityVal `fmap` selectList [PersonColor <-. [Just "blue"]] [] - liftIO $ x3 @?= [p3] - x4 <- fmap entityVal `fmap` selectList [PersonColor /<-. [Just "blue"]] [] - liftIO $ x4 @?= [p1, p2] - - x5 <- fmap entityVal `fmap` selectList [PersonColor <-. [Nothing, Just "blue"]] [] - liftIO $ x5 @?= [p1, p2, p3] - x6 <- fmap entityVal `fmap` selectList [PersonColor /<-. [Nothing]] [] - liftIO $ x6 @?= [p3] - - describe "toJSON" $ do - it "serializes" $ runDb $ do - let p = Person "D" 0 Nothing - k <- insert p - liftIO $ toJSON (Entity k p) @?= - object [("id", toJSON k), ("color",Null),("name",String "D"),("age",Number 0)] - -{- FIXME - prop "fromJSON . toJSON $ key" $ \(person :: Key Person) -> - case (fromJSON . toJSON) person of - Success p -> p == person - _ -> error "fromJSON" --} - - describe "strictness" $ do - it "bang" $ (return $! Strict (error "foo") 5 5) `shouldThrow` anyErrorCall - it "tilde" $ void (return $! Strict 5 (error "foo") 5 :: IO Strict) - it "blank" $ (return $! Strict 5 5 (error "foo")) `shouldThrow` anyErrorCall - - describe "documentation syntax" $ do - let edef = entityDef (Proxy :: Proxy Relationship) - it "provides comments on entity def" $ do - getEntityComments edef - `shouldBe` - Just "This is a doc comment for a relationship.\nOnly the first line requires a pipe.\nPipes are optional on subsequent lines.\n" - it "provides comments on the field" $ do - let [nameField, _] = getEntityFields edef - fieldComments nameField - `shouldBe` - Just "Fields should be documentable.\n" +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module PersistentTest + ( module PersistentTest + , cleanDB + , testMigrate + , noPrefixMigrate + , customPrefixMigrate + , treeMigrate + ) where + +import Control.Monad.Fail +import Control.Monad.IO.Class +import Data.Aeson +import Data.Conduit +import qualified Data.Conduit.List as CL +import Data.Functor.Constant +import Data.Functor.Identity +import qualified Data.Map as Map +import Data.Maybe (fromJust) +import Data.Proxy (Proxy (..)) +import Test.HUnit hiding (Test) +import Test.Hspec.QuickCheck (prop) +import UnliftIO (MonadUnliftIO, catch) +import Web.PathPieces (PathPiece (..)) + +import Database.Persist +import Init +import PersistTestPetCollarType +import PersistTestPetType +import PersistentTestModels + +catchPersistException :: (MonadUnliftIO m, MonadFail m) => m a -> b -> m b +catchPersistException action errValue = do + Left res <- + (Right `fmap` action) + `catch` (\(_ :: PersistException) -> return $ Left errValue) + return res + +filterOrSpecs + :: forall m backend + . (Runner backend m) + => RunDb backend m + -> Spec +filterOrSpecs runDb = describe "FilterOr" $ do + it "FilterOr []" $ runDb $ do + let + p = Person "z" 1 Nothing + insert_ p + ps <- selectList [FilterOr []] [Desc PersonAge] + assertEmpty ps + it "||. []" $ runDb $ do + let + p = Person "z" 1 Nothing + insert_ p + c <- count $ [PersonName ==. "a"] ||. [] + c @== (1 :: Int) + +-- Test proper polymorphism +_polymorphic + :: ( MonadFail m + , MonadIO m + , PersistQuery backend + , BaseBackend backend ~ PersistEntityBackend Pet + ) + => ReaderT backend m () +_polymorphic = do + ((Entity id' _) : _) <- selectList [] [LimitTo 1] + _ <- selectList [PetOwnerId ==. id'] [] + insert_ $ Pet id' "foo" Cat + return () + +-- Some lens stuff +type ASetter s t a b = (a -> Identity b) -> s -> Identity t + +set :: ASetter s t a b -> b -> s -> t +set l b = runIdentity . (l (\_ -> Identity b)) + +type Getting r s t a b = (a -> Constant r b) -> s -> Constant r t + +view :: s -> Getting a s t a b -> a +view s l = getConstant (l Constant s) + +safeToRemoveSpec + :: forall backend m. (Runner backend m) => RunDb backend m -> Spec +safeToRemoveSpec runDb = do + describe "DudeWeirdColumns" $ do + it "can insert and get" $ do + let + m = DudeWeirdColumns "hello" + runDb $ do + k <- insert m + mval <- get k + liftIO $ fmap dudeWeirdColumnsName mval `shouldBe` Just "hello" + it "can putMany" $ do + let + ms = + [ DudeWeirdColumns "hello" + , DudeWeirdColumns "goodbyue" + ] + runDb $ putMany ms + +specsWith :: forall backend m. (Runner backend m) => RunDb backend m -> Spec +specsWith runDb = describe "persistent" $ do + describe "SafeToRemove" (safeToRemoveSpec runDb) + it "fieldLens" $ do + let + michael = Entity undefined $ Person "Michael" 28 Nothing :: Entity Person + michaelP1 = Person "Michael" 29 Nothing :: Person + view michael (fieldLens PersonAge) @?= 28 + entityVal (set (fieldLens PersonAge) 29 michael) @?= michaelP1 + + it "FilterAnd []" $ runDb $ do + let + p = Person "z" 1 Nothing + insert_ p + ps <- selectList [FilterAnd []] [Desc PersonAge] + assertNotEmpty ps + + it "Filter In" $ runDb $ do + _ <- selectList [Filter PersonName (FilterValues ["Kostas"]) In] [] + return () + + it "order of opts is irrelevant" $ runDb $ do + let + eq (a, b, _) (c, d) = (a, b) @== (c, d) + limitOffsetOrder' :: [SelectOpt Person] -> (Int, Int, [SelectOpt Person]) + limitOffsetOrder' = limitOffsetOrder + limitOffsetOrder' [Desc PersonAge] `eq` (0, 0) + limitOffsetOrder' [LimitTo 2, Desc PersonAge] `eq` (2, 0) + limitOffsetOrder' [Desc PersonAge, LimitTo 2] `eq` (2, 0) + limitOffsetOrder' [LimitTo 2, Desc PersonAge, OffsetBy 3] `eq` (2, 3) + + insertMany_ + [ Person "z" 1 Nothing + , Person "y" 2 Nothing + , Person "x" 1 Nothing + , Person "w" 2 Nothing + , Person "v" 1 Nothing + , Person "u" 2 Nothing + ] + + a <- + map (personName . entityVal) + <$> selectList [] [Desc PersonAge, Asc PersonName, OffsetBy 2, LimitTo 3] + a @== ["y", "v", "x"] + + b <- + map (personName . entityVal) + <$> selectList [] [OffsetBy 2, Desc PersonAge, LimitTo 3, Asc PersonName] + b @== a + + c <- + map (personName . entityVal) + <$> selectList + [] + [OffsetBy 2, Desc PersonAge, LimitTo 3, Asc PersonName, LimitTo 1, OffsetBy 1] + c @== a + + it "passes the general tests" $ runDb $ do + let + mic26 = Person "Michael" 26 Nothing + micK <- insert mic26 + results <- selectList [PersonName ==. "Michael"] [] + results @== [Entity micK mic26] + + results' <- selectList [PersonAge <. 28] [] + results' @== [Entity micK mic26] + + p28 <- updateGet micK [PersonAge =. 28] + personAge p28 @== 28 + + updateWhere [PersonName ==. "Michael"] [PersonAge =. 29] + uc <- count [PersonName ==. "Michael"] + uc @== 1 + 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 + pasc <- selectList [] [Asc PersonAge] + map entityVal pasc @== [eli, mic29] + + let + abe30 = Person "Abe" 30 $ Just "black" + insert_ abe30 + -- pdesc <- selectList [PersonAge <. 30] [Desc PersonName] + map entityVal pasc @== [eli, mic29] + + abes <- selectList [PersonName ==. "Abe"] [] + map entityVal abes @== [abe30] + + Just (Entity _ p3) <- getBy $ PersonNameKey "Michael" + p3 @== mic29 + + ps <- selectList [PersonColor ==. Just "blue"] [] + map entityVal ps @== [eli] + + ps2 <- selectList [PersonColor ==. Nothing] [] + map entityVal ps2 @== [mic29] + + delete micK + Nothing <- get micK + return () + it "persistIdField" $ runDb $ do + let + p = Person "foo" 100 (Just "blue") + q = Person "bar" 101 Nothing + pk <- insert p + qk <- insert q + + mp <- selectFirst [persistIdField ==. pk] [] + fmap entityVal mp @== Just p + + mq <- selectFirst [persistIdField ==. qk] [] + fmap entityVal mq @== Just q + + it "!=." $ runDb $ do + deleteWhere ([] :: [Filter (PersonGeneric backend)]) + let + mic = Person "Michael" 25 Nothing + insert_ mic + let + eli = Person "Eliezer" 25 (Just "Red") + insert_ eli + + pne <- selectList [PersonName !=. "Michael"] [] + map entityVal pne @== [eli] + + ps <- selectList [PersonColor !=. Nothing] [] + map entityVal ps @== [eli] + + pnm <- selectList [PersonName !=. "Eliezer"] [] + map entityVal pnm @== [mic] + + it "Double Maybe" $ runDb $ do + deleteWhere ([] :: [Filter (PersonMayGeneric backend)]) + let + mic = PersonMay (Just "Michael") Nothing + insert_ mic + let + eli = PersonMay (Just "Eliezer") (Just "Red") + insert_ eli + pe <- selectList [PersonMayName ==. Nothing, PersonMayColor ==. Nothing] [] + map entityVal pe @== [] + pne <- selectList [PersonMayName !=. Nothing, PersonMayColor !=. Nothing] [] + map entityVal pne @== [eli] + + it "and/or" $ runDb $ do + deleteWhere ([] :: [Filter (Person1Generic backend)]) + insertMany_ + [ Person1 "Michael" 25 + , Person1 "Miriam" 25 + , Person1 "Michael" 30 + , Person1 "Michael" 35 + ] + + c10 <- + count $ + [Person1Name ==. "Michael"] ||. [Person1Name ==. "Miriam", Person1Age ==. 25] + c10 @== 4 + c12 <- + count + [ FilterOr + [FilterAnd [Person1Name ==. "Michael"], FilterAnd [Person1Name ==. "Miriam"]] + ] + c12 @== 4 + c14 <- + count + [ FilterOr + [ FilterAnd [Person1Name ==. "Michael"] + , FilterAnd [Person1Name ==. "Miriam"] + , FilterAnd [Person1Age >. 29, Person1Age <=. 30] + ] + ] + c14 @== 4 + + c20 <- + count $ [Person1Name ==. "Miriam"] ||. [Person1Age >. 29, Person1Age <=. 30] + c20 @== 2 + c22 <- count $ [Person1Age <=. 30] ++ [Person1Age >. 29] + c22 @== 1 + c24 <- count $ [FilterAnd [Person1Age <=. 30, Person1Age >. 29]] + c24 @== 1 + c26 <- count $ [Person1Age <=. 30] ++ [Person1Age >. 29] + c26 @== 1 + + c34 <- + count $ + [Person1Name ==. "Michael"] + ||. [Person1Name ==. "Mirieam"] ++ [Person1Age <. 35] + c34 @== 3 + c30 <- + count $ + ([Person1Name ==. "Michael"] ||. [Person1Name ==. "Miriam"]) + ++ [Person1Age <. 35] + c30 @== 3 + c36 <- + count $ + [Person1Name ==. "Michael"] + ||. ([Person1Name ==. "Miriam"] ++ [Person1Age <. 35]) + c36 @== 4 + + c40 <- + count $ + ( [Person1Name ==. "Michael"] + ||. [Person1Name ==. "Miriam"] + ||. [Person1Age <. 35] + ) + c40 @== 4 + + it "deleteWhere" $ runDb $ do + key2 <- insert $ Person "Michael2" 90 Nothing + _ <- insert $ Person "Michael3" 90 Nothing + let + p91 = Person "Michael4" 91 Nothing + key91 <- insert p91 + + ps90 <- selectList [PersonAge ==. 90] [] + assertNotEmpty ps90 + deleteWhere [PersonAge ==. 90] + ps90' <- selectList [PersonAge ==. 90] [] + assertEmpty ps90' + Nothing <- get key2 + + Just p2_91 <- get key91 + p91 @== p2_91 + + it "deleteBy" $ runDb $ do + insert_ $ Person "Michael2" 27 Nothing + let + p3 = Person "Michael3" 27 Nothing + key3 <- insert p3 + + ps2 <- selectList [PersonName ==. "Michael2"] [] + assertNotEmpty ps2 + + deleteBy $ PersonNameKey "Michael2" + ps2' <- selectList [PersonName ==. "Michael2"] [] + assertEmpty ps2' + + Just p32 <- get key3 + p3 @== p32 + + it "delete" $ runDb $ do + key2 <- insert $ Person "Michael2" 27 Nothing + let + p3 = Person "Michael3" 27 Nothing + key3 <- insert p3 + + pm2 <- selectList [PersonName ==. "Michael2"] [] + assertNotEmpty pm2 + delete key2 + pm2' <- selectList [PersonName ==. "Michael2"] [] + assertEmpty pm2' + + Just p <- get key3 + p3 @== p + + prop "toPathPiece . fromPathPiece" $ \piece -> + let + key1 = piece :: (BackendKey SqlBackend) + key2 = fromJust $ fromPathPiece $ toPathPiece key1 :: (BackendKey SqlBackend) + in + toPathPiece key1 == toPathPiece key2 + + it "replace" $ runDb $ do + key2 <- insert $ Person "Michael2" 27 Nothing + let + p3 = Person "Michael3" 27 Nothing + replace key2 p3 + Just p <- get key2 + p @== p3 + + -- test replace an empty key + delete key2 + Nothing <- get key2 + _ <- replace key2 p3 + Nothing <- get key2 + return () + + let + mic = Person "Michael" 25 Nothing + micK <- insert mic + Just p1 <- get micK + p1 @== mic + + replace micK $ Person "Michael" 25 Nothing + Just p2 <- get micK + p2 @== mic + + replace micK $ Person "Michael" 26 Nothing + Just mic26 <- get micK + mic26 @/= mic + personAge mic26 @== personAge mic + 1 + + it "getBy" $ runDb $ do + let + p2 = Person "Michael2" 27 Nothing + key2 <- insert p2 + Just (Entity k p) <- getBy $ PersonNameKey "Michael2" + p @== p2 + k @== key2 + Nothing <- getBy $ PersonNameKey "Michael9" + + Just (Entity k' p') <- getByValue p2 + k' @== k + p' @== p + return () + + it "updateGet" $ runDb $ do + let + p25 = Person "Michael" 25 Nothing + key25 <- insert p25 + pBlue28 <- updateGet key25 [PersonAge =. 28, PersonName =. "Updated"] + pBlue28 @== Person "Updated" 28 Nothing + pBlue30 <- updateGet key25 [PersonAge +=. 2] + pBlue30 @== Person "Updated" 30 Nothing + + describe "repsertMany" $ do + it "adds new rows when no conflicts" $ runDb $ do + ids@[johnId, janeId, aliceId, eveId] <- + replicateM 4 $ liftIO (Person1Key `fmap` generateKey) + let + john = Person1 "john" 20 + let + jane = Person1 "jane" 18 + let + alice = Person1 "alice" 18 + let + eve = Person1 "eve" 19 + + insertKey johnId john + insertKey janeId jane + + _ <- repsertMany [(aliceId, alice), (eveId, eve)] + es <- getMany ids + + let + rs = [john, jane, alice, eve] + es @== Map.fromList (zip ids rs) + mapM_ delete ids + + it "handles conflicts by replacing old keys with new records" $ runDb $ do + let + john = Person1 "john" 20 + let + jane = Person1 "jane" 18 + let + alice = Person1 "alice" 18 + let + eve = Person1 "eve" 19 + + johnId <- insert john + janeId <- insert jane + + _ <- repsertMany [(johnId, alice), (janeId, eve)] + (Just alice') <- get johnId + (Just eve') <- get janeId + + [alice', eve'] @== [alice, eve] + mapM_ delete [johnId, janeId] + + it "updateWhere" $ runDb $ do + let + p1 = Person "Michael" 25 Nothing + let + p2 = Person "Michael2" 25 Nothing + key1 <- insert p1 + key2 <- insert p2 + updateWhere + [PersonName ==. "Michael2"] + [PersonAge +=. 3, PersonName =. "Updated"] + Just pBlue28 <- get key2 + pBlue28 @== Person "Updated" 28 Nothing + Just p <- get key1 + p @== p1 + + it "selectList" $ runDb $ do + let + p25 = Person "Michael" 25 Nothing + let + p26 = Person "Michael2" 26 Nothing + [key25, key26] <- insertMany [p25, p26] + ps1 <- selectList [] [Asc PersonAge] + ps1 @== [(Entity key25 p25), (Entity key26 p26)] + -- limit + ps2 <- selectList [] [Asc PersonAge, LimitTo 1] + ps2 @== [(Entity key25 p25)] + -- offset + ps3 <- selectList [] [Asc PersonAge, OffsetBy 1] + ps3 @== [(Entity key26 p26)] + -- limit & offset + ps4 <- selectList [] [Asc PersonAge, LimitTo 1, OffsetBy 1] + ps4 @== [(Entity key26 p26)] + + ps5 <- selectList [] [Desc PersonAge] + ps5 @== [(Entity key26 p26), (Entity key25 p25)] + ps6 <- selectList [PersonAge ==. 26] [] + ps6 @== [(Entity key26 p26)] + + it "selectSource" $ runDb $ do + let + p1 = Person "selectSource1" 1 Nothing + p2 = Person "selectSource2" 2 Nothing + p3 = Person "selectSource3" 3 Nothing + [k1, k2, k3] <- insertMany [p1, p2, p3] + + ps1 <- runConduitRes $ selectSource [] [Desc PersonAge] .| await + ps1 @== Just (Entity k3 p3) + + ps2 <- + runConduitRes $ selectSource [PersonAge <. 3] [Asc PersonAge] .| CL.consume + ps2 @== [Entity k1 p1, Entity k2 p2] + + runConduitRes $ + selectSource [] [Desc PersonAge] .| do + e1 <- await + e1 @== Just (Entity k3 p3) + + e2 <- await + e2 @== Just (Entity k2 p2) + + e3 <- await + e3 @== Just (Entity k1 p1) + + e4 <- await + e4 @== Nothing + + it "selectFirst" $ runDb $ do + insert_ $ Person "Michael" 26 Nothing + let + pOld = Person "Oldie" 75 Nothing + kOld <- insert pOld + + x <- selectFirst [] [Desc PersonAge] + x @== Just (Entity kOld pOld) + + it "selectKeys" $ runDb $ do + let + p1 = Person "selectKeys1" 1 Nothing + p2 = Person "selectKeys2" 2 Nothing + p3 = Person "selectKeys3" 3 Nothing + [k1, k2, k3] <- insertMany [p1, p2, p3] + + ps1 <- runConduitRes $ selectKeys [] [Desc PersonAge] .| await + ps1 @== Just k3 + + ps2 <- runConduitRes $ selectKeys [PersonAge <. 3] [Asc PersonAge] .| CL.consume + ps2 @== [k1, k2] + + runConduitRes $ + selectKeys [] [Desc PersonAge] .| do + e1 <- await + e1 @== Just k3 + + e2 <- await + e2 @== Just k2 + + e3 <- await + e3 @== Just k1 + + e4 <- await + e4 @== Nothing + + it "insertMany_ with no arguments" $ runDb $ do + _ <- insertMany_ ([] :: [PersonGeneric backend]) + rows <- + (count ([] :: [Filter (PersonGeneric backend)]) :: ReaderT backend m Int) + rows @== 0 + _ <- insertMany ([] :: [PersonGeneric backend]) + rows2 <- count ([] :: [Filter (PersonGeneric backend)]) + rows2 @== 0 + _ <- insertEntityMany ([] :: [Entity (PersonGeneric backend)]) + rows3 <- count ([] :: [Filter (PersonGeneric backend)]) + rows3 @== 0 + + it "insertEntityMany" $ runDb $ do + id1 : id2 : id3 : id4 : id5 : [] <- + liftIO $ replicateM 5 (PersonKey `fmap` generateKey) + let + p1 = Entity id1 $ Person "insertEntityMany1" 1 Nothing + p2 = Entity id2 $ Person "insertEntityMany2" 2 Nothing + p3 = Entity id3 $ Person "insertEntityMany3" 3 Nothing + p4 = Entity id4 $ Person "insertEntityMany4" 3 Nothing + p5 = Entity id5 $ Person "insertEntityMany5" 3 Nothing + insertEntityMany [p1, p2, p3, p4, p5] + rows <- count ([] :: [Filter (PersonGeneric backend)]) + rows @== 5 + + it "insertBy" $ runDb $ do + Right _ <- insertBy $ Person "name" 1 Nothing + Left _ <- insertBy $ Person "name" 1 Nothing + Right _ <- insertBy $ Person "name2" 1 Nothing + return () + + it "insertKey" $ runDb $ do + k <- liftIO (PersonKey `fmap` generateKey) + insertKey k $ Person "Key" 26 Nothing + Just (Entity k2 _) <- selectFirst [PersonName ==. "Key"] [] + k2 @== k + + it "insertEntity" $ runDb $ do + Entity k p <- insertEntity $ Person "name" 1 Nothing + Just p2 <- get k + p2 @== p + + it "insertRecord" $ runDb $ do + let + record = Person "name" 1 Nothing + record' <- insertRecord record + record' @== record + + it "getEntity" $ runDb $ do + Entity k p <- insertEntity $ Person "name" 1 Nothing + Just (Entity k2 p2) <- getEntity k + p @== p2 + k @== k2 + + it "getJustEntity" $ runDb $ do + let + p1 = Person "name" 1 Nothing + k1 <- insert p1 + Entity k2 p2 <- getJustEntity k1 + p1 @== p2 + k1 @== k2 + + it "repsert" $ runDb $ do + k <- liftIO (PersonKey `fmap` generateKey) + Nothing <- selectFirst [PersonName ==. "Repsert"] [] + repsert k $ Person "Repsert" 26 Nothing + Just (Entity k2 _) <- selectFirst [PersonName ==. "Repsert"] [] + k2 @== k + repsert k $ Person "Repsert" 27 Nothing + Just (Entity k3 p) <- selectFirst [PersonName ==. "Repsert"] [] + k3 @== k + 27 @== personAge p + + it "retrieves a belongsToJust association" $ runDb $ do + let + p = Person "pet owner" 30 Nothing + person <- insert p + let + cat = Pet person "Mittens" Cat + p2 <- getJust $ petOwnerId cat + p @== p2 + p3 <- belongsToJust petOwnerId cat + p @== p3 + + it "retrieves a belongsTo association" $ runDb $ do + let + p = Person "pet owner" 30 Nothing + person <- insert p + let + cat = MaybeOwnedPet (Just person) "Mittens" Cat + p2 <- getJust $ fromJust $ maybeOwnedPetOwnerId cat + p @== p2 + Just p4 <- belongsTo maybeOwnedPetOwnerId cat + p @== p4 + + it "derivePersistField" $ runDb $ do + person <- insert $ Person "pet owner" 30 Nothing + catKey <- insert $ Pet person "Mittens" Cat + Just cat' <- get catKey + liftIO $ petType cat' @?= Cat + dog <- insert $ Pet person "Spike" Dog + Just dog' <- get dog + liftIO $ petType dog' @?= Dog + + it "derivePersistFieldJSON" $ runDb $ do + let + mittensCollar = PetCollar "Mittens\n1-714-668-9672" True + pkey <- insert $ Person "pet owner" 30 Nothing + catKey <- insert $ OutdoorPet pkey mittensCollar Cat + Just (OutdoorPet _ collar' _) <- get catKey + liftIO $ collar' @?= mittensCollar + + it "idIn" $ runDb $ do + let + p1 = Person "D" 0 Nothing + p2 = Person "E" 1 Nothing + p3 = Person "F" 2 Nothing + pid1 <- insert p1 + insert_ p2 + pid3 <- insert p3 + x <- selectList [PersonId <-. [pid1, pid3]] [] + liftIO $ x @?= [Entity pid1 p1, Entity pid3 p3] + + it "In" $ runDb $ do + let + p1 = Person "D" 0 Nothing + p2 = Person "E" 1 Nothing + p3 = Person "F" 2 (Just "blue") + insert_ p1 + insert_ p2 + insert_ p3 + x1 <- fmap entityVal `fmap` selectList [PersonName <-. ["D"]] [] + liftIO $ x1 @?= [p1] + x2 <- fmap entityVal `fmap` selectList [PersonName /<-. ["D"]] [] + liftIO $ x2 @?= [p2, p3] + + x3 <- fmap entityVal `fmap` selectList [PersonColor <-. [Just "blue"]] [] + liftIO $ x3 @?= [p3] + x4 <- fmap entityVal `fmap` selectList [PersonColor /<-. [Just "blue"]] [] + liftIO $ x4 @?= [p1, p2] + + x5 <- + fmap entityVal `fmap` selectList [PersonColor <-. [Nothing, Just "blue"]] [] + liftIO $ x5 @?= [p1, p2, p3] + x6 <- fmap entityVal `fmap` selectList [PersonColor /<-. [Nothing]] [] + liftIO $ x6 @?= [p3] + + describe "toJSON" $ do + it "serializes" $ runDb $ do + let + p = Person "D" 0 Nothing + k <- insert p + liftIO $ + toJSON (Entity k p) + @?= object + [("id", toJSON k), ("color", Null), ("name", String "D"), ("age", Number 0)] + + {- FIXME + prop "fromJSON . toJSON $ key" $ \(person :: Key Person) -> + case (fromJSON . toJSON) person of + Success p -> p == person + _ -> error "fromJSON" + -} + + describe "strictness" $ do + it "bang" $ (return $! Strict (error "foo") 5 5) `shouldThrow` anyErrorCall + it "tilde" $ void (return $! Strict 5 (error "foo") 5 :: IO Strict) + it "blank" $ (return $! Strict 5 5 (error "foo")) `shouldThrow` anyErrorCall + + describe "documentation syntax" $ do + let + edef = entityDef (Proxy :: Proxy Relationship) + it "provides comments on entity def" $ do + getEntityComments edef + `shouldBe` Just + "This is a doc comment for a relationship.\nOnly the first line requires a pipe.\nPipes are optional on subsequent lines.\n" + it "provides comments on the field" $ do + let + [nameField, _] = getEntityFields edef + fieldComments nameField + `shouldBe` Just "Fields should be documentable.\n" diff --git a/src/PersistentTestModelsImports.hs b/src/PersistentTestModelsImports.hs --- a/src/PersistentTestModelsImports.hs +++ b/src/PersistentTestModelsImports.hs @@ -1,12 +1,14 @@ {-# LANGUAGE TypeOperators #-} -{-# language UndecidableInstances #-} +{-# LANGUAGE UndecidableInstances #-} -- | this just needs to compile module PersistentTestModelsImports where import Database.Persist.TH -share [mkPersist sqlSettings] [persistUpperCase| +share + [mkPersist sqlSettings] + [persistUpperCase| User name String diff --git a/src/PrimaryTest.hs b/src/PrimaryTest.hs --- a/src/PrimaryTest.hs +++ b/src/PrimaryTest.hs @@ -1,14 +1,16 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE DeriveGeneric #-} module PrimaryTest where 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 "migration"] [persistLowerCase| +share + [mkPersist persistSettings{mpsGeneric = False}, mkMigrate "migration"] + [persistLowerCase| Foo name String Primary name @@ -28,33 +30,33 @@ Primary name age |] - -cleanDB :: (MonadIO m, PersistQuery backend, PersistEntityBackend Foo ~ backend) => ReaderT backend m () +cleanDB + :: (MonadIO m, PersistQuery backend, PersistEntityBackend Foo ~ backend) + => ReaderT backend m () cleanDB = do - deleteWhere ([] :: [Filter Foo]) - deleteWhere ([] :: [Filter Bar]) + deleteWhere ([] :: [Filter Foo]) + deleteWhere ([] :: [Filter Bar]) specsWith :: (MonadIO m, MonadFail m) => RunDb SqlBackend m -> Spec specsWith runDb = describe "primary key reference" $ do - it "insert a primary reference" $ runDb $ do - kf <- insert $ Foo "name" - _kb <- insert $ Bar kf - return () - it "uses RawSql for a Primary key" $ runDb $ do - key <- insert $ Foo "name" - keyFromRaw <- rawSql "SELECT name FROM foo LIMIT 1" [] - [key] @== keyFromRaw - describe "keyFromRecordM" $ do - it "works on singleton case" $ do - let - foo = Foo "hello" - fooKey = fmap ($ foo) keyFromRecordM - fooKey `shouldBe` Just (FooKey "hello") - it "works on multiple fields" $ do - let - name = "hello" - age = 31 - rec = CompositePrimary name age - fmap ($ rec) keyFromRecordM - `shouldBe` - Just (CompositePrimaryKey name age) + it "insert a primary reference" $ runDb $ do + kf <- insert $ Foo "name" + _kb <- insert $ Bar kf + return () + it "uses RawSql for a Primary key" $ runDb $ do + key <- insert $ Foo "name" + keyFromRaw <- rawSql "SELECT name FROM foo LIMIT 1" [] + [key] @== keyFromRaw + describe "keyFromRecordM" $ do + it "works on singleton case" $ do + let + foo = Foo "hello" + fooKey = fmap ($ foo) keyFromRecordM + fooKey `shouldBe` Just (FooKey "hello") + it "works on multiple fields" $ do + let + name = "hello" + age = 31 + rec = CompositePrimary name age + fmap ($ rec) keyFromRecordM + `shouldBe` Just (CompositePrimaryKey name age) diff --git a/src/RawSqlTest.hs b/src/RawSqlTest.hs --- a/src/RawSqlTest.hs +++ b/src/RawSqlTest.hs @@ -1,4 +1,5 @@ -{-# language ScopedTypeVariables, DataKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} module RawSqlTest where @@ -9,129 +10,211 @@ import qualified Data.Text as T import Database.Persist.Class.PersistEntity -import Init import Database.Persist.SqlBackend +import Init import PersistTestPetType import PersistentTestModels -specsWith :: Runner SqlBackend m => RunDb SqlBackend m -> Spec +specsWith :: (Runner SqlBackend m) => RunDb SqlBackend m -> Spec specsWith runDb = describe "rawSql" $ do it "2+2" $ runDb $ do ret <- rawSql "SELECT 2+2" [] - liftIO $ ret @?= [Single (4::Int)] + liftIO $ ret @?= [Single (4 :: Int)] it "?-?" $ runDb $ do ret <- rawSql "SELECT ?-?" [PersistInt64 5, PersistInt64 3] - liftIO $ ret @?= [Single (2::Int)] + liftIO $ ret @?= [Single (2 :: Int)] it "NULL" $ runDb $ do ret <- rawSql "SELECT NULL" [] liftIO $ ret @?= [Nothing :: Maybe (Single Int)] it "entity" $ runDb $ do - Entity p1k p1 <- insertEntity $ Person "Mathias" 23 Nothing - Entity p2k p2 <- insertEntity $ Person "Norbert" 44 Nothing - Entity p3k _ <- insertEntity $ Person "Cassandra" 19 Nothing - Entity _ _ <- insertEntity $ Person "Thiago" 19 Nothing + Entity p1k p1 <- insertEntity $ Person "Mathias" 23 Nothing + Entity p2k p2 <- insertEntity $ Person "Norbert" 44 Nothing + Entity p3k _ <- insertEntity $ Person "Cassandra" 19 Nothing + Entity _ _ <- insertEntity $ Person "Thiago" 19 Nothing Entity a1k a1 <- insertEntity $ Pet p1k "Rodolfo" Cat - Entity a2k a2 <- insertEntity $ Pet p1k "Zeno" Cat - Entity a3k a3 <- insertEntity $ Pet p2k "Lhama" Dog - Entity _ _ <- insertEntity $ Pet p3k "Abacate" Cat + Entity a2k a2 <- insertEntity $ Pet p1k "Zeno" Cat + Entity a3k a3 <- insertEntity $ Pet p2k "Lhama" Dog + 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 - 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_ - ] + 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_ + ] ret <- rawSql query [PersistInt64 20] - liftIO $ ret @?= [ (Entity p1k p1, Entity a1k a1) - , (Entity p1k p1, Entity a2k a2) - , (Entity p2k p2, Entity a3k a3) ] + liftIO $ + ret + @?= [ (Entity p1k p1, Entity a1k a1) + , (Entity p1k p1, Entity a2k a2) + , (Entity p2k p2, Entity a3k a3) + ] ret2 <- rawSql query [PersistInt64 20] - liftIO $ ret2 @?= [ (Just (Entity p1k p1), Just (Entity a1k a1)) - , (Just (Entity p1k p1), Just (Entity a2k a2)) - , (Just (Entity p2k p2), Just (Entity a3k a3)) ] + liftIO $ + ret2 + @?= [ (Just (Entity p1k p1), Just (Entity a1k a1)) + , (Just (Entity p1k p1), Just (Entity a2k a2)) + , (Just (Entity p2k p2), Just (Entity a3k a3)) + ] ret3 <- rawSql query [PersistInt64 20] - liftIO $ ret3 @?= [ Just (Entity p1k p1, Entity a1k a1) - , Just (Entity p1k p1, Entity a2k a2) - , Just (Entity p2k p2, Entity a3k a3) ] + liftIO $ + ret3 + @?= [ Just (Entity p1k p1, Entity a1k a1) + , Just (Entity p1k p1, Entity a2k a2) + , Just (Entity p2k p2, Entity a3k a3) + ] it "order-proof" $ runDb $ do - let p1 = Person "Zacarias" 93 Nothing + let + p1 = Person "Zacarias" 93 Nothing p1k <- insert p1 escape <- getEscape - let query = T.concat [ "SELECT ?? " - , "FROM ", escape "Person" - ] + let + query = + T.concat + [ "SELECT ?? " + , "FROM " + , escape "Person" + ] ret1 <- rawSql query [] - ret2 <- rawSql query [] :: MonadIO m => SqlPersistT m [Entity (ReverseFieldOrder Person)] + ret2 <- + rawSql query [] + :: (MonadIO m) => SqlPersistT m [Entity (ReverseFieldOrder Person)] liftIO $ ret1 @?= [Entity p1k p1] liftIO $ ret2 @?= [Entity (RFOKey $ unPersonKey p1k) (RFO p1)] it "permits prefixes" $ runDb $ do - let r1 = Relationship "Foo" Nothing + let + r1 = Relationship "Foo" Nothing r1k <- insert r1 - let r2 = Relationship "Bar" (Just r1k) + let + r2 = Relationship "Bar" (Just r1k) r2k <- insert r2 - let r3 = Relationship "Lmao" (Just r1k) + let + r3 = Relationship "Lmao" (Just r1k) r3k <- insert r3 - let r4 = Relationship "Boring" (Just r2k) + let + r4 = Relationship "Boring" (Just r2k) r4k <- insert r4 escape <- getEscape - let query = T.concat - [ "SELECT ??, ?? " - , "FROM ", escape "Relationship", " AS parent " - , "LEFT OUTER JOIN ", escape "Relationship", " AS child " - , "ON parent.id = child.parent" - ] + let + query = + T.concat + [ "SELECT ??, ?? " + , "FROM " + , escape "Relationship" + , " AS parent " + , "LEFT OUTER JOIN " + , escape "Relationship" + , " AS child " + , "ON parent.id = child.parent" + ] - result :: [(EntityWithPrefix "parent" Relationship, Maybe (EntityWithPrefix "child" Relationship))] <- + result + :: [ ( EntityWithPrefix "parent" Relationship + , Maybe (EntityWithPrefix "child" Relationship) + ) + ] <- rawSql query [] liftIO $ - coerce result `shouldMatchList` - [ (Entity r1k r1, Just (Entity r2k r2)) - , (Entity r1k r1, Just (Entity r3k r3)) - , (Entity r2k r2, Just (Entity r4k r4)) - , (Entity r3k r3, Nothing) - , (Entity r4k r4, Nothing) - ] - + coerce result + `shouldMatchList` [ (Entity r1k r1, Just (Entity r2k r2)) + , (Entity r1k r1, Just (Entity r3k r3)) + , (Entity r2k r2, Just (Entity r4k r4)) + , (Entity r3k r3, Nothing) + , (Entity r4k r4, Nothing) + ] it "OUTER JOIN" $ runDb $ do - let insert' :: (PersistStore backend, PersistEntity val, PersistEntityBackend val ~ BaseBackend backend, MonadIO m, SafeToInsert val) - => val -> ReaderT backend m (Key val, val) + 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 - (p2k, p2) <- insert' $ Person "Norbert" 44 Nothing + (p1k, p1) <- insert' $ Person "Mathias" 23 Nothing + (p2k, p2) <- insert' $ Person "Norbert" 44 Nothing (a1k, a1) <- insert' $ Pet p1k "Rodolfo" Cat - (a2k, a2) <- insert' $ Pet p1k "Zeno" Cat + (a2k, a2) <- insert' $ Pet p1k "Zeno" Cat escape <- getEscape - let query = T.concat [ "SELECT ??, ?? " - , "FROM ", person - , "LEFT OUTER JOIN ", pet - , " ON ", person, ".", escape "id" - , " = ", pet, ".", escape "ownerId" - , " ORDER BY ", person, ".", escape "name" - , ", ", pet, ".", escape "id" ] + let + query = + T.concat + [ "SELECT ??, ?? " + , "FROM " + , person + , "LEFT OUTER JOIN " + , pet + , " ON " + , person + , "." + , escape "id" + , " = " + , pet + , "." + , escape "ownerId" + , " ORDER BY " + , person + , "." + , escape "name" + , ", " + , pet + , "." + , escape "id" + ] person = escape "Person" - pet = escape "Pet" + pet = escape "Pet" ret <- rawSql query [] - liftIO $ ret @?= [ (Entity p1k p1, Just (Entity a1k a1)) - , (Entity p1k p1, Just (Entity a2k a2)) - , (Entity p2k p2, Nothing) ] + liftIO $ + ret + @?= [ (Entity p1k p1, Just (Entity a1k a1)) + , (Entity p1k p1, Just (Entity a2k a2)) + , (Entity p2k p2, Nothing) + ] it "handles lower casing" $ runDb $ do - C.runConduitRes $ rawQuery "SELECT full_name from lower_case_table WHERE my_id=5" [] C..| CL.sinkNull - C.runConduitRes $ rawQuery "SELECT something_else from ref_table WHERE id=4" [] C..| CL.sinkNull + C.runConduitRes $ + rawQuery "SELECT full_name from lower_case_table WHERE my_id=5" [] + C..| CL.sinkNull + C.runConduitRes $ + rawQuery "SELECT something_else from ref_table WHERE id=4" [] C..| CL.sinkNull it "commit/rollback" $ do caseCommitRollback runDb @@ -140,18 +223,40 @@ it "queries with large number of results" $ runDb $ do -- max size of a GHC tuple is 62, but Eq instances currently only exist up to 15-tuples -- See https://gitlab.haskell.org/ghc/ghc/-/merge_requests/3369 - ret <- rawSql "SELECT ?,?,?,?,?,?,?,?,?,?,?,?,?,?,?" $ map PersistInt64 [1..15] - 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))] + ret <- + rawSql "SELECT ?,?,?,?,?,?,?,?,?,?,?,?,?,?,?" $ map PersistInt64 [1 .. 15] + 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 :: (MonadReader SqlBackend m) => m (Text -> Text) getEscape = getEscapeRawNameFunction -caseCommitRollback :: Runner SqlBackend m => RunDb SqlBackend m -> Assertion +caseCommitRollback :: (Runner SqlBackend m) => RunDb SqlBackend m -> Assertion caseCommitRollback runDb = runDb $ do - let filt :: [Filter Person1] + let + filt :: [Filter Person1] filt = [] - let p = Person1 "foo" 0 + let + p = Person1 "foo" 0 insert_ p insert_ p diff --git a/src/ReadWriteTest.hs b/src/ReadWriteTest.hs --- a/src/ReadWriteTest.hs +++ b/src/ReadWriteTest.hs @@ -1,15 +1,17 @@ {-# LANGUAGE ScopedTypeVariables #-} + module ReadWriteTest where import Init import PersistentTestModels - -specsWith :: forall m. Runner SqlBackend m => RunDb SqlBackend m -> Spec +specsWith :: forall m. (Runner SqlBackend m) => RunDb SqlBackend m -> Spec specsWith originalRunDb = describe "ReadWriteTest" $ do - let personFilters = [] :: [Filter Person] + let + personFilters = [] :: [Filter Person] describe "SqlReadBackend" $ do - let runDb :: RunDb SqlReadBackend m + let + runDb :: RunDb SqlReadBackend m runDb = changeBackend SqlReadBackend originalRunDb it "type checks on all PersistStoreRead functions" $ do runDb $ do @@ -29,12 +31,14 @@ pure () describe "SqlWriteBackend" $ do - let runDb :: RunDb SqlWriteBackend m + let + runDb :: RunDb SqlWriteBackend m runDb = changeBackend SqlWriteBackend originalRunDb it "type checks on PersistStoreWrite and Read functions" $ do runDb $ do - let person = Person "Matt Parsons" 30 Nothing + let + person = Person "Matt Parsons" 30 Nothing k <- insert person mperson <- get k Just person @== mperson @@ -46,7 +50,8 @@ it "type checks on PersistUniqueWrite/Read functions" $ do runDb $ do - let name_ = "Matt Parsons New" + let + name_ = "Matt Parsons New" person = Person name_ 30 Nothing _mkey0 <- insertUnique person mkey1 <- insertUnique person @@ -54,13 +59,11 @@ mperson <- selectFirst [PersonName ==. name_] [] fmap entityVal mperson @== Just person - let nameLuke = "Luke Seale New" + let + nameLuke = "Luke Seale New" personLuke = Person nameLuke 31 Nothing mkey2 <- insertUnique_ personLuke mkey3 <- insertUnique_ personLuke mkey3 @== Nothing mpersonLuke <- selectFirst [PersonName ==. nameLuke] [] fmap entityVal mpersonLuke @== Just personLuke - - - diff --git a/src/Recursive.hs b/src/Recursive.hs --- a/src/Recursive.hs +++ b/src/Recursive.hs @@ -1,13 +1,14 @@ -{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeOperators #-} - +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-} module Recursive (specsWith, recursiveMigrate, cleanup) where import Init -share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "recursiveMigrate"] [persistLowerCase| +share + [mkPersist sqlSettings{mpsGeneric = True}, mkMigrate "recursiveMigrate"] + [persistLowerCase| SubType object [MenuObject] @@ -23,22 +24,24 @@ :: (PersistStoreWrite (BaseBackend backend), PersistQueryWrite backend) => ReaderT backend IO () cleanup = do - deleteWhere ([] :: [Filter (MenuObjectGeneric backend)]) - deleteWhere ([] :: [Filter (SubTypeGeneric backend)]) + deleteWhere ([] :: [Filter (MenuObjectGeneric backend)]) + deleteWhere ([] :: [Filter (SubTypeGeneric backend)]) specsWith - :: - ( PersistStoreWrite backend - , PersistStoreWrite (BaseBackend backend) - , MonadIO m - ) + :: ( PersistStoreWrite backend + , PersistStoreWrite (BaseBackend backend) + , MonadIO m + ) => RunDb backend m -> Spec specsWith runDb = describe "recursive definitions" $ do - it "mutually recursive" $ runDb $ do - let m1 = MenuObject $ Just $ SubType [] - let m2 = MenuObject $ Just $ SubType [m1] - let m3 = MenuObject $ Just $ SubType [m2] - k3 <- insert m3 - m3' <- get k3 - m3' @== Just m3 + it "mutually recursive" $ runDb $ do + let + m1 = MenuObject $ Just $ SubType [] + let + m2 = MenuObject $ Just $ SubType [m1] + let + m3 = MenuObject $ Just $ SubType [m2] + k3 <- insert m3 + m3' <- get k3 + m3' @== Just m3 diff --git a/src/RenameTest.hs b/src/RenameTest.hs --- a/src/RenameTest.hs +++ b/src/RenameTest.hs @@ -1,10 +1,12 @@ -{-# LANGUAGE TypeApplications, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} module RenameTest where import qualified Data.Map as Map import qualified Data.Text as T -import Data.Time (getCurrentTime, Day, UTCTime(..)) +import Data.Time (Day, UTCTime (..), getCurrentTime) import Init @@ -13,7 +15,9 @@ type TextId = Text -- Test lower case names -share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "migration"] [persistLowerCase| +share + [mkPersist sqlSettings{mpsGeneric = True}, mkMigrate "migration"] + [persistLowerCase| -- This just tests that a field can be named "key" KeyTable key Text @@ -53,47 +57,51 @@ |] cleanDB - :: forall backend. - ( BaseBackend backend ~ backend - , PersistQueryWrite backend - ) + :: forall backend + . ( BaseBackend backend ~ backend + , PersistQueryWrite backend + ) => ReaderT backend IO () cleanDB = do - deleteWhere ([] :: [Filter (IdTableGeneric backend)]) - deleteWhere ([] :: [Filter (LowerCaseTableGeneric backend)]) - deleteWhere ([] :: [Filter (RefTableGeneric backend)]) + deleteWhere ([] :: [Filter (IdTableGeneric backend)]) + deleteWhere ([] :: [Filter (LowerCaseTableGeneric backend)]) + deleteWhere ([] :: [Filter (RefTableGeneric backend)]) specsWith - :: - ( PersistStoreWrite backend, PersistQueryRead backend - , backend ~ BaseBackend backend - , MonadIO m, MonadFail m - , Eq (BackendKey backend) - ) + :: ( PersistStoreWrite backend + , PersistQueryRead backend + , backend ~ BaseBackend backend + , MonadIO m + , MonadFail m + , Eq (BackendKey backend) + ) => RunDb backend m -> Spec specsWith runDb = describe "rename specs" $ do describe "LowerCaseTable" $ do it "LowerCaseTable has the right sql name" $ do fmap fieldDB (getEntityIdField (entityDef (Proxy @LowerCaseTable))) - `shouldBe` - Just (FieldNameDB "my_id") + `shouldBe` Just (FieldNameDB "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 + 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 + let + key = IdTableKey $ utctDay now insertKey key rec Just rec' <- get key rec' @== rec - (Entity key' _):_ <- selectList ([] :: [Filter (IdTableGeneric backend)]) [] + (Entity key' _) : _ <- selectList ([] :: [Filter (IdTableGeneric backend)]) [] key' @== key it "extra blocks" $ - getEntityExtra (entityDef (Nothing :: Maybe LowerCaseTable)) @?= - Map.fromList + getEntityExtra (entityDef (Nothing :: Maybe LowerCaseTable)) + @?= Map.fromList [ ("ExtraBlock", map T.words ["foo bar", "baz", "bin"]) , ("ExtraBlock2", map T.words ["something"]) ] diff --git a/src/SumTypeTest.hs b/src/SumTypeTest.hs --- a/src/SumTypeTest.hs +++ b/src/SumTypeTest.hs @@ -2,6 +2,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-} + module SumTypeTest (specsWith, sumTypeMigrate) where import qualified Data.Text as T @@ -9,7 +10,9 @@ import Database.Persist.TH import Init -share [mkPersist persistSettings { mpsGeneric = True }, mkMigrate "sumTypeMigrate"] [persistLowerCase| +share + [mkPersist persistSettings{mpsGeneric = True}, mkMigrate "sumTypeMigrate"] + [persistLowerCase| Bicycle brand T.Text Car @@ -23,35 +26,37 @@ -- This is needed for mpsGeneric = True -- The typical persistent user sets mpsGeneric = False -- https://ghc.haskell.org/trac/ghc/ticket/8100 -deriving instance Show (BackendKey backend) => Show (VehicleGeneric backend) -deriving instance Eq (BackendKey backend) => Eq (VehicleGeneric backend) +deriving instance (Show (BackendKey backend)) => Show (VehicleGeneric backend) +deriving instance (Eq (BackendKey backend)) => Eq (VehicleGeneric backend) specsWith - :: - ( PersistQueryWrite backend - , BaseBackend backend ~ backend - , MonadIO m, MonadFail m - ) + :: ( PersistQueryWrite backend + , BaseBackend backend ~ backend + , MonadIO m + , MonadFail m + ) => RunDb backend m -> Maybe (ReaderT backend m a) -- ^ Optional migrations for SQL backends -> Spec specsWith runDb mmigrate = describe "sum types" $ - it "works" $ asIO $ runDb $ do - sequence_ mmigrate - car1 <- insert $ Car "Ford" "Thunderbird" - car2 <- insert $ Car "Kia" "Rio" - bike1 <- insert $ Bicycle "Shwinn" + it "works" $ + asIO $ + runDb $ do + sequence_ mmigrate + car1 <- insert $ Car "Ford" "Thunderbird" + car2 <- insert $ Car "Kia" "Rio" + bike1 <- insert $ Bicycle "Shwinn" - vc1 <- insert $ VehicleCarSum car1 - vc2 <- insert $ VehicleCarSum car2 - vb1 <- insert $ VehicleBicycleSum bike1 + vc1 <- insert $ VehicleCarSum car1 + vc2 <- insert $ VehicleCarSum car2 + vb1 <- insert $ VehicleBicycleSum bike1 - x1 <- get vc1 - liftIO $ x1 @?= Just (VehicleCarSum car1) + x1 <- get vc1 + liftIO $ x1 @?= Just (VehicleCarSum car1) - x2 <- get vc2 - liftIO $ x2 @?= Just (VehicleCarSum car2) + x2 <- get vc2 + liftIO $ x2 @?= Just (VehicleCarSum car2) - x3 <- get vb1 - liftIO $ x3 @?= Just (VehicleBicycleSum bike1) + x3 <- get vb1 + liftIO $ x3 @?= Just (VehicleBicycleSum bike1) diff --git a/src/TransactionLevelTest.hs b/src/TransactionLevelTest.hs --- a/src/TransactionLevelTest.hs +++ b/src/TransactionLevelTest.hs @@ -6,7 +6,9 @@ import Init -share [mkPersist sqlSettings, mkMigrate "migration"] [persistUpperCase| +share + [mkPersist sqlSettings, mkMigrate "migration"] + [persistUpperCase| Wombat name Text sqltype=varchar(80) @@ -17,12 +19,13 @@ specsWith :: (MonadIO m, MonadFail m) => RunDb SqlBackend m -> Spec specsWith runDb = describe "IsolationLevel" $ do - let item = Wombat "uno" - isolationLevels = [minBound..maxBound] - forM_ isolationLevels $ \il -> describe "insertOnDuplicateKeyUpdate" $ do - it (show il ++ " works") $ runDb $ do - transactionUndoWithIsolation il - deleteWhere ([] :: [Filter Wombat]) - insert_ item - Just item' <- get (WombatKey "uno") - item' @== item + let + item = Wombat "uno" + isolationLevels = [minBound .. maxBound] + forM_ isolationLevels $ \il -> describe "insertOnDuplicateKeyUpdate" $ do + it (show il ++ " works") $ runDb $ do + transactionUndoWithIsolation il + deleteWhere ([] :: [Filter Wombat]) + 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 @@ -1,17 +1,19 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE RecordWildCards, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} module TreeTest where 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 } + [ mkPersist persistSettings{mpsGeneric = False} , mkMigrate "treeMigrate" - ] [persistLowerCase| + ] + [persistLowerCase| Tree sql=trees name Text parent Text Maybe @@ -19,12 +21,11 @@ Foreign Tree fkparent parent |] - cleanDB :: (PersistQuery backend, PersistEntityBackend Tree ~ backend, MonadIO m) => ReaderT backend m () cleanDB = do - deleteWhere ([] :: [Filter Tree]) + deleteWhere ([] :: [Filter Tree]) specsWith :: (MonadIO m, MonadFail m) => RunDb SqlBackend m -> Spec specsWith runDb = describe "tree" $ do @@ -39,29 +40,32 @@ gp <- getJust kgp treeFkparent gp @== Nothing describe "entityDef" $ do - let ed = entityDef (Proxy :: Proxy Tree) + let + ed = entityDef (Proxy :: Proxy Tree) it "has the right haskell name" $ do getEntityHaskellName ed `shouldBe` EntityNameHS "Tree" it "has the right DB name" $ do getEntityDBName ed `shouldBe` EntityNameDB "trees" describe "foreign ref" $ do - let [ForeignDef{..}] = getEntityForeignDefs (entityDef (Proxy :: Proxy Tree)) + let + [ForeignDef{..}] = getEntityForeignDefs (entityDef (Proxy :: Proxy Tree)) it "has the right haskell name" $ do - foreignRefTableHaskell `shouldBe` - EntityNameHS "Tree" + foreignRefTableHaskell + `shouldBe` EntityNameHS "Tree" it "has the right db name" $ do - foreignRefTableDBName `shouldBe` - EntityNameDB "trees" + foreignRefTableDBName + `shouldBe` EntityNameDB "trees" it "has the right constraint name" $ do - foreignConstraintNameHaskell `shouldBe` - ConstraintNameHS "fkparent" + foreignConstraintNameHaskell + `shouldBe` ConstraintNameHS "fkparent" it "has the right DB constraint name" $ do - foreignConstraintNameDBName `shouldBe` - ConstraintNameDB "treefkparent" + foreignConstraintNameDBName + `shouldBe` ConstraintNameDB "treefkparent" it "has the right fields" $ do - foreignFields `shouldBe` - [ ( (FieldNameHS "parent", FieldNameDB "parent") - , (FieldNameHS "name", FieldNameDB "name") - ) - ] + foreignFields + `shouldBe` [ + ( (FieldNameHS "parent", FieldNameDB "parent") + , (FieldNameHS "name", FieldNameDB "name") + ) + ] diff --git a/src/TypeLitFieldDefsTest.hs b/src/TypeLitFieldDefsTest.hs --- a/src/TypeLitFieldDefsTest.hs +++ b/src/TypeLitFieldDefsTest.hs @@ -30,7 +30,11 @@ instance PersistFieldSql (Labelled n) where sqlType _ = sqlType (Proxy :: Proxy Int) -share [mkPersist sqlSettings { mpsGeneric = True }, mkMigrate "typeLitFieldDefsMigrate"] [persistLowerCase| +share + [ mkPersist sqlSettings{mpsGeneric = True} + , mkMigrate "typeLitFieldDefsMigrate" + ] + [persistLowerCase| TypeLitFieldDefsNumeric one (Finite 1) twenty (Finite 20) @@ -54,7 +58,7 @@ twentyLabelled :: Labelled "twenty" twentyLabelled = Labelled 20 -specsWith :: Runner backend m => RunDb backend m -> Spec +specsWith :: (Runner backend m) => RunDb backend m -> Spec specsWith runDb = describe "Type Lit Field Definitions" $ do it "runs appropriate migrations" $ runDb $ do diff --git a/src/UniqueTest.hs b/src/UniqueTest.hs --- a/src/UniqueTest.hs +++ b/src/UniqueTest.hs @@ -1,11 +1,14 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} + module UniqueTest where import Init -share [mkPersist sqlSettings, mkMigrate "uniqueMigrate"] [persistLowerCase| +share + [mkPersist sqlSettings, mkMigrate "uniqueMigrate"] + [persistLowerCase| TestNonNull fieldA Int UniqueTestNonNull fieldA sql=UniqueTestNonNull !force @@ -24,39 +27,51 @@ deriving Eq Show |] -cleanDB :: (MonadIO m, PersistQuery backend, PersistEntityBackend TestNonNull ~ backend) => ReaderT backend m () +cleanDB + :: (MonadIO m, PersistQuery backend, PersistEntityBackend TestNonNull ~ backend) + => ReaderT backend m () cleanDB = do - deleteWhere ([] :: [Filter TestNonNull]) - deleteWhere ([] :: [Filter TestNull]) + deleteWhere ([] :: [Filter TestNonNull]) + deleteWhere ([] :: [Filter TestNull]) -specsWith :: Runner SqlBackend m => RunDb SqlBackend m -> Spec +specsWith :: (Runner SqlBackend m) => RunDb SqlBackend m -> Spec specsWith runDb = - describe "uniqueness constraints" $ do - it "are respected for non-nullable Ints" $ do - let ins = insert . TestNonNull - (runDb $ void $ ins 1 >> ins 2) - (runDb $ void $ ins 1 >> ins 2 >> ins 1) `shouldThrow` anyException - (runDb $ void $ ins 1 >>= \k -> ins 2 >> delete k >> ins 1) - it "are respected for nullable Ints" $ do - let ins a b = insert $ TestNull a b - ctx = ins 1 Nothing >> ins 1 Nothing >> ins 1 Nothing >> - ins 1 (Just 3) >> ins 1 (Just 4) - (runDb $ void ctx) - (runDb $ void $ ctx >> ins 1 (Just 3)) `shouldThrow` anyException - (runDb $ void $ ctx >> ins 1 (Just 4)) `shouldThrow` anyException - (runDb $ void $ ctx >>= \k -> delete k >> ins 1 (Just 4)) - it "work for Checkmark" $ do - let ins k v a = insert $ TestCheckmark k v a - ctx = ins "name" "John" Inactive - >> ins "name" "Stewart" Inactive - >> ins "name" "Doroty" Active - >> ins "color" "blue" Inactive - (runDb $ void ctx) - (runDb $ void $ ctx >> ins "name" "Melissa" Active) `shouldThrow` anyException - (runDb $ void $ ctx >> ins "name" "Melissa" Inactive) - (runDb $ void $ ctx >>= flip update [TestCheckmarkActive =. Active]) - (runDb $ void $ do - void ctx - updateWhere [TestCheckmarkName ==. "name"] - [TestCheckmarkActive =. Inactive] - ins "name" "Melissa" Active) + describe "uniqueness constraints" $ do + it "are respected for non-nullable Ints" $ do + let + ins = insert . TestNonNull + (runDb $ void $ ins 1 >> ins 2) + (runDb $ void $ ins 1 >> ins 2 >> ins 1) `shouldThrow` anyException + (runDb $ void $ ins 1 >>= \k -> ins 2 >> delete k >> ins 1) + it "are respected for nullable Ints" $ do + let + ins a b = insert $ TestNull a b + ctx = + ins 1 Nothing + >> ins 1 Nothing + >> ins 1 Nothing + >> ins 1 (Just 3) + >> ins 1 (Just 4) + (runDb $ void ctx) + (runDb $ void $ ctx >> ins 1 (Just 3)) `shouldThrow` anyException + (runDb $ void $ ctx >> ins 1 (Just 4)) `shouldThrow` anyException + (runDb $ void $ ctx >>= \k -> delete k >> ins 1 (Just 4)) + it "work for Checkmark" $ do + let + ins k v a = insert $ TestCheckmark k v a + ctx = + ins "name" "John" Inactive + >> ins "name" "Stewart" Inactive + >> ins "name" "Doroty" Active + >> ins "color" "blue" Inactive + (runDb $ void ctx) + (runDb $ void $ ctx >> ins "name" "Melissa" Active) `shouldThrow` anyException + (runDb $ void $ ctx >> ins "name" "Melissa" Inactive) + (runDb $ void $ ctx >>= flip update [TestCheckmarkActive =. Active]) + ( runDb $ void $ do + void ctx + updateWhere + [TestCheckmarkName ==. "name"] + [TestCheckmarkActive =. Inactive] + ins "name" "Melissa" Active + ) diff --git a/src/UpsertTest.hs b/src/UpsertTest.hs --- a/src/UpsertTest.hs +++ b/src/UpsertTest.hs @@ -20,173 +20,186 @@ | UpsertPreserveOldKey specsWith - :: forall backend m. Runner backend m + :: forall backend m + . (Runner backend m) => RunDb backend m -> BackendNullUpdateBehavior -> BackendUpsertKeyBehavior -> Spec specsWith runDb handleNull handleKey = describe "UpsertTests" $ do - let - ifKeyIsPreserved expectation = - case handleKey of - UpsertGenerateNewKey -> pure () - UpsertPreserveOldKey -> expectation - - describe "upsert" $ do - it "adds a new row with no updates" $ runDb $ do - Entity _ u <- upsert (Upsert "a" "new" "" 2) [UpsertAttr =. "update"] - c <- count ([] :: [Filter (UpsertGeneric backend)]) - c @== 1 - upsertAttr u @== "new" - it "keeps the existing row" $ runDb $ do - Entity k0 initial <- insertEntity (Upsert "a" "initial" "" 1) - Entity k1 update' <- upsert (Upsert "a" "update" "" 2) [] - update' @== initial - ifKeyIsPreserved $ k0 @== k1 - it "updates an existing row - assignment" $ runDb $ do --- #ifdef WITH_MONGODB --- initial <- insertEntity (Upsert "cow" "initial" "extra" 1) --- update' <- --- upsert (Upsert "cow" "wow" "such unused" 2) [UpsertAttr =. "update"] --- ((==@) `on` entityKey) initial update' --- upsertAttr (entityVal update') @== "update" --- upsertExtra (entityVal update') @== "extra" --- #else - initial <- insertEntity (Upsert "a" "initial" "extra" 1) - update' <- - upsert (Upsert "a" "wow" "such unused" 2) [UpsertAttr =. "update"] - ifKeyIsPreserved $ ((==@) `on` entityKey) initial update' - upsertAttr (entityVal update') @== "update" - upsertExtra (entityVal update') @== "extra" --- #endif - it "updates existing row - addition " $ runDb $ do --- #ifdef WITH_MONGODB --- initial <- insertEntity (Upsert "a1" "initial" "extra" 2) --- update' <- --- upsert (Upsert "a1" "wow" "such unused" 2) [UpsertAge +=. 3] --- ((==@) `on` entityKey) initial update' --- upsertAge (entityVal update') @== 5 --- upsertExtra (entityVal update') @== "extra" --- #else - initial <- insertEntity (Upsert "a" "initial" "extra" 2) - update' <- - upsert (Upsert "a" "wow" "such unused" 2) [UpsertAge +=. 3] - ifKeyIsPreserved $ ((==@) `on` entityKey) initial update' - upsertAge (entityVal update') @== 5 - upsertExtra (entityVal update') @== "extra" --- #endif + let + ifKeyIsPreserved expectation = + case handleKey of + UpsertGenerateNewKey -> pure () + UpsertPreserveOldKey -> expectation - describe "upsertBy" $ do - let uniqueEmail = UniqueUpsertBy "a" - _uniqueCity = UniqueUpsertByCity "Boston" - it "adds a new row with no updates" $ runDb $ do - Entity _ u <- - upsertBy - uniqueEmail - (UpsertBy "a" "Boston" "new") - [UpsertByAttr =. "update"] - c <- count ([] :: [Filter (UpsertByGeneric backend)]) - c @== 1 - upsertByAttr u @== "new" - it "keeps the existing row" $ runDb $ do - Entity k0 initial <- insertEntity (UpsertBy "a" "Boston" "initial") - Entity k1 update' <- upsertBy uniqueEmail (UpsertBy "a" "Boston" "update") [] - update' @== initial - ifKeyIsPreserved $ k0 @== k1 - it "updates an existing row" $ runDb $ do --- #ifdef WITH_MONGODB --- initial <- insertEntity (UpsertBy "ko" "Kumbakonam" "initial") --- update' <- --- upsertBy --- (UniqueUpsertBy "ko") --- (UpsertBy "ko" "Bangalore" "such unused") --- [UpsertByAttr =. "update"] --- ((==@) `on` entityKey) initial update' --- upsertByAttr (entityVal update') @== "update" --- upsertByCity (entityVal update') @== "Kumbakonam" --- #else - initial <- insertEntity (UpsertBy "a" "Boston" "initial") - update' <- - upsertBy - uniqueEmail - (UpsertBy "a" "wow" "such unused") - [UpsertByAttr =. "update"] - ifKeyIsPreserved $ ((==@) `on` entityKey) initial update' - upsertByAttr (entityVal update') @== "update" - upsertByCity (entityVal update') @== "Boston" --- #endif - it "updates by the appropriate constraint" $ runDb $ do - initBoston <- insertEntity (UpsertBy "bos" "Boston" "bos init") - initKrum <- insertEntity (UpsertBy "krum" "Krum" "krum init") - updBoston <- - upsertBy - (UniqueUpsertBy "bos") - (UpsertBy "bos" "Krum" "unused") - [UpsertByAttr =. "bos update"] - updKrum <- - upsertBy - (UniqueUpsertByCity "Krum") - (UpsertBy "bos" "Krum" "unused") - [UpsertByAttr =. "krum update"] - ifKeyIsPreserved $ ((==@) `on` entityKey) initBoston updBoston - ifKeyIsPreserved $ ((==@) `on` entityKey) initKrum updKrum - entityVal updBoston @== UpsertBy "bos" "Boston" "bos update" - entityVal updKrum @== UpsertBy "krum" "Krum" "krum update" + describe "upsert" $ do + it "adds a new row with no updates" $ runDb $ do + Entity _ u <- upsert (Upsert "a" "new" "" 2) [UpsertAttr =. "update"] + c <- count ([] :: [Filter (UpsertGeneric backend)]) + c @== 1 + upsertAttr u @== "new" + it "keeps the existing row" $ runDb $ do + Entity k0 initial <- insertEntity (Upsert "a" "initial" "" 1) + Entity k1 update' <- upsert (Upsert "a" "update" "" 2) [] + update' @== initial + ifKeyIsPreserved $ k0 @== k1 + it "updates an existing row - assignment" $ runDb $ do + -- #ifdef WITH_MONGODB + -- initial <- insertEntity (Upsert "cow" "initial" "extra" 1) + -- update' <- + -- upsert (Upsert "cow" "wow" "such unused" 2) [UpsertAttr =. "update"] + -- ((==@) `on` entityKey) initial update' + -- upsertAttr (entityVal update') @== "update" + -- upsertExtra (entityVal update') @== "extra" + -- #else + initial <- insertEntity (Upsert "a" "initial" "extra" 1) + update' <- + upsert (Upsert "a" "wow" "such unused" 2) [UpsertAttr =. "update"] + ifKeyIsPreserved $ ((==@) `on` entityKey) initial update' + upsertAttr (entityVal update') @== "update" + upsertExtra (entityVal update') @== "extra" + -- #endif + it "updates existing row - addition " $ runDb $ do + -- #ifdef WITH_MONGODB + -- initial <- insertEntity (Upsert "a1" "initial" "extra" 2) + -- update' <- + -- upsert (Upsert "a1" "wow" "such unused" 2) [UpsertAge +=. 3] + -- ((==@) `on` entityKey) initial update' + -- upsertAge (entityVal update') @== 5 + -- upsertExtra (entityVal update') @== "extra" + -- #else + initial <- insertEntity (Upsert "a" "initial" "extra" 2) + update' <- + upsert (Upsert "a" "wow" "such unused" 2) [UpsertAge +=. 3] + ifKeyIsPreserved $ ((==@) `on` entityKey) initial update' + upsertAge (entityVal update') @== 5 + upsertExtra (entityVal update') @== "extra" + -- #endif - it "maybe update" $ runDb $ do - let noAge = PersonMaybeAge "Michael" Nothing - keyNoAge <- insert noAge - noAge2 <- updateGet keyNoAge [PersonMaybeAgeAge +=. Just 2] - -- the correct answer depends on the backend. MongoDB assumes - -- a 'Nothing' value is 0, and does @0 + 2@ for @Just 2@. In a SQL - -- database, @NULL@ annihilates, so @NULL + 2 = NULL@. - personMaybeAgeAge noAge2 @== case handleNull of - AssumeNullIsZero -> - Just 2 - Don'tUpdateNull -> - Nothing + describe "upsertBy" $ do + let + uniqueEmail = UniqueUpsertBy "a" + _uniqueCity = UniqueUpsertByCity "Boston" + it "adds a new row with no updates" $ runDb $ do + Entity _ u <- + upsertBy + uniqueEmail + (UpsertBy "a" "Boston" "new") + [UpsertByAttr =. "update"] + c <- count ([] :: [Filter (UpsertByGeneric backend)]) + c @== 1 + upsertByAttr u @== "new" + it "keeps the existing row" $ runDb $ do + Entity k0 initial <- insertEntity (UpsertBy "a" "Boston" "initial") + Entity k1 update' <- upsertBy uniqueEmail (UpsertBy "a" "Boston" "update") [] + update' @== initial + ifKeyIsPreserved $ k0 @== k1 + it "updates an existing row" $ runDb $ do + -- #ifdef WITH_MONGODB + -- initial <- insertEntity (UpsertBy "ko" "Kumbakonam" "initial") + -- update' <- + -- upsertBy + -- (UniqueUpsertBy "ko") + -- (UpsertBy "ko" "Bangalore" "such unused") + -- [UpsertByAttr =. "update"] + -- ((==@) `on` entityKey) initial update' + -- upsertByAttr (entityVal update') @== "update" + -- upsertByCity (entityVal update') @== "Kumbakonam" + -- #else + initial <- insertEntity (UpsertBy "a" "Boston" "initial") + update' <- + upsertBy + uniqueEmail + (UpsertBy "a" "wow" "such unused") + [UpsertByAttr =. "update"] + ifKeyIsPreserved $ ((==@) `on` entityKey) initial update' + upsertByAttr (entityVal update') @== "update" + upsertByCity (entityVal update') @== "Boston" + -- #endif + it "updates by the appropriate constraint" $ runDb $ do + initBoston <- insertEntity (UpsertBy "bos" "Boston" "bos init") + initKrum <- insertEntity (UpsertBy "krum" "Krum" "krum init") + updBoston <- + upsertBy + (UniqueUpsertBy "bos") + (UpsertBy "bos" "Krum" "unused") + [UpsertByAttr =. "bos update"] + updKrum <- + upsertBy + (UniqueUpsertByCity "Krum") + (UpsertBy "bos" "Krum" "unused") + [UpsertByAttr =. "krum update"] + ifKeyIsPreserved $ ((==@) `on` entityKey) initBoston updBoston + ifKeyIsPreserved $ ((==@) `on` entityKey) initKrum updKrum + entityVal updBoston @== UpsertBy "bos" "Boston" "bos update" + entityVal updKrum @== UpsertBy "krum" "Krum" "krum update" - describe "putMany" $ do - it "adds new rows when entity has no unique constraints" $ runDb $ do - let mkPerson name_ = Person1 name_ 25 - let names = ["putMany bob", "putMany bob", "putMany smith"] - let records = map mkPerson names - _ <- putMany records - entitiesDb <- selectList [Person1Name <-. names] [] - let recordsDb = fmap entityVal entitiesDb - recordsDb @== records - deleteWhere [Person1Name <-. names] - it "adds new rows when no conflicts" $ runDb $ do - let mkUpsert e = Upsert e "new" "" 1 - let keys = ["putMany1","putMany2","putMany3"] - let vals = map mkUpsert keys - _ <- putMany vals - Just (Entity _ v1) <- getBy $ UniqueUpsert "putMany1" - Just (Entity _ v2) <- getBy $ UniqueUpsert "putMany2" - Just (Entity _ v3) <- getBy $ UniqueUpsert "putMany3" - [v1,v2,v3] @== vals - deleteBy $ UniqueUpsert "putMany1" - deleteBy $ UniqueUpsert "putMany2" - deleteBy $ UniqueUpsert "putMany3" - it "handles conflicts by replacing old keys with new records" $ runDb $ do - let mkUpsert1 e = Upsert e "new" "" 1 - let mkUpsert2 e = Upsert e "new" "" 2 - let vals = map mkUpsert2 ["putMany4", "putMany5", "putMany6", "putMany7"] - Entity k1 _ <- insertEntity $ mkUpsert1 "putMany4" - Entity k2 _ <- insertEntity $ mkUpsert1 "putMany5" - _ <- putMany $ mkUpsert1 "putMany4" : vals - Just e1 <- getBy $ UniqueUpsert "putMany4" - Just e2 <- getBy $ UniqueUpsert "putMany5" - Just e3@(Entity k3 _) <- getBy $ UniqueUpsert "putMany6" - Just e4@(Entity k4 _) <- getBy $ UniqueUpsert "putMany7" + it "maybe update" $ runDb $ do + let + noAge = PersonMaybeAge "Michael" Nothing + keyNoAge <- insert noAge + noAge2 <- updateGet keyNoAge [PersonMaybeAgeAge +=. Just 2] + -- the correct answer depends on the backend. MongoDB assumes + -- a 'Nothing' value is 0, and does @0 + 2@ for @Just 2@. In a SQL + -- database, @NULL@ annihilates, so @NULL + 2 = NULL@. + personMaybeAgeAge noAge2 @== case handleNull of + AssumeNullIsZero -> + Just 2 + Don'tUpdateNull -> + Nothing - [e1,e2,e3,e4] @== [ Entity k1 (mkUpsert2 "putMany4") - , Entity k2 (mkUpsert2 "putMany5") - , Entity k3 (mkUpsert2 "putMany6") - , Entity k4 (mkUpsert2 "putMany7") - ] - deleteBy $ UniqueUpsert "putMany4" - deleteBy $ UniqueUpsert "putMany5" - deleteBy $ UniqueUpsert "putMany6" - deleteBy $ UniqueUpsert "putMany7" + describe "putMany" $ do + it "adds new rows when entity has no unique constraints" $ runDb $ do + let + mkPerson name_ = Person1 name_ 25 + let + names = ["putMany bob", "putMany bob", "putMany smith"] + let + records = map mkPerson names + _ <- putMany records + entitiesDb <- selectList [Person1Name <-. names] [] + let + recordsDb = fmap entityVal entitiesDb + recordsDb @== records + deleteWhere [Person1Name <-. names] + it "adds new rows when no conflicts" $ runDb $ do + let + mkUpsert e = Upsert e "new" "" 1 + let + keys = ["putMany1", "putMany2", "putMany3"] + let + vals = map mkUpsert keys + _ <- putMany vals + Just (Entity _ v1) <- getBy $ UniqueUpsert "putMany1" + Just (Entity _ v2) <- getBy $ UniqueUpsert "putMany2" + Just (Entity _ v3) <- getBy $ UniqueUpsert "putMany3" + [v1, v2, v3] @== vals + deleteBy $ UniqueUpsert "putMany1" + deleteBy $ UniqueUpsert "putMany2" + deleteBy $ UniqueUpsert "putMany3" + it "handles conflicts by replacing old keys with new records" $ runDb $ do + let + mkUpsert1 e = Upsert e "new" "" 1 + let + mkUpsert2 e = Upsert e "new" "" 2 + let + vals = map mkUpsert2 ["putMany4", "putMany5", "putMany6", "putMany7"] + Entity k1 _ <- insertEntity $ mkUpsert1 "putMany4" + Entity k2 _ <- insertEntity $ mkUpsert1 "putMany5" + _ <- putMany $ mkUpsert1 "putMany4" : vals + Just e1 <- getBy $ UniqueUpsert "putMany4" + Just e2 <- getBy $ UniqueUpsert "putMany5" + Just e3@(Entity k3 _) <- getBy $ UniqueUpsert "putMany6" + Just e4@(Entity k4 _) <- getBy $ UniqueUpsert "putMany7" + [e1, e2, e3, e4] + @== [ Entity k1 (mkUpsert2 "putMany4") + , Entity k2 (mkUpsert2 "putMany5") + , Entity k3 (mkUpsert2 "putMany6") + , Entity k4 (mkUpsert2 "putMany7") + ] + deleteBy $ UniqueUpsert "putMany4" + deleteBy $ UniqueUpsert "putMany5" + deleteBy $ UniqueUpsert "putMany6" + deleteBy $ UniqueUpsert "putMany7"