persistent-test (empty) → 2.0.0.3
raw patch · 32 files changed
+3996/−0 lines, 32 filesdep +HUnitdep +QuickCheckdep +aesonsetup-changed
Dependencies added: HUnit, QuickCheck, aeson, aeson-compat, attoparsec, base, base64-bytestring, binary, blaze-builder, blaze-html, blaze-markup, bson, bytestring, cereal, conduit, containers, exceptions, fast-logger, hashable, hspec, hspec-expectations, http-api-data, hzk, lifted-base, monad-logger, mongoDB, mtl, mysql, mysql-simple, network, old-locale, path-pieces, persistent, persistent-mongoDB, persistent-mysql, persistent-postgresql, persistent-sqlite, persistent-template, persistent-test, persistent-zookeeper, postgresql-libpq, postgresql-simple, process, quickcheck-instances, random, resource-pool, resourcet, scientific, semigroups, silently, system-fileio, system-filepath, tagged, template-haskell, text, time, transformers, transformers-base, unliftio, unliftio-core, unordered-containers, utf8-string, vector
Files
- LICENSE +20/−0
- Setup.lhs +7/−0
- persistent-test.cabal +208/−0
- src/CompositeTest.hs +311/−0
- src/CustomPersistField.hs +23/−0
- src/CustomPersistFieldTest.hs +33/−0
- src/CustomPrimaryKeyReferenceTest.hs +53/−0
- src/DataTypeTest.hs +198/−0
- src/EmbedOrderTest.hs +72/−0
- src/EmbedTest.hs +443/−0
- src/EmptyEntityTest.hs +36/−0
- src/EntityEmbedTest.hs +18/−0
- src/EquivalentTypeTest.hs +61/−0
- src/HtmlTest.hs +58/−0
- src/Init.hs +343/−0
- src/InsertDuplicateUpdate.hs +103/−0
- src/LargeNumberTest.hs +47/−0
- src/MaxLenTest.hs +55/−0
- src/MigrationColumnLengthTest.hs +32/−0
- src/MigrationIdempotencyTest.hs +36/−0
- src/MigrationOnlyTest.hs +54/−0
- src/MigrationTest.hs +62/−0
- src/PersistTestPetCollarType.hs +15/−0
- src/PersistTestPetType.hs +8/−0
- src/PersistUniqueTest.hs +44/−0
- src/PersistentTest.hs +1208/−0
- src/PrimaryTest.hs +51/−0
- src/Recursive.hs +42/−0
- src/RenameTest.hs +108/−0
- src/SumTypeTest.hs +58/−0
- src/UniqueTest.hs +73/−0
- test/main.hs +116/−0
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.lhs view
@@ -0,0 +1,7 @@+#!/usr/bin/env runhaskell++> module Main where+> import Distribution.Simple++> main :: IO ()+> main = defaultMain
+ persistent-test.cabal view
@@ -0,0 +1,208 @@+name: persistent-test+version: 2.0.0.3+license: MIT+license-file: LICENSE+author: Michael Snoyman <michael@snoyman.com>+maintainer: Michael Snoyman <michael@snoyman.com>+synopsis: Tests for Persistent+description: Tests for Persistent+category: Database, Yesod+stability: Stable+cabal-version: >= 1.10+build-type: Simple+homepage: http://www.yesodweb.com/book/persistent+bug-reports: https://github.com/yesodweb/persistent/issues++extra-source-files:+ test/main.hs++Flag sqlite+ Description: use sqlite. This is just present for consistency, and is not used+ Default: False+ manual: True++Flag zookeeper+ Description: test only Zookeeper. default is to test just sqlite.+ Default: False+ manual: True++Flag mongodb+ Description: test only MongoDB. default is to test just sqlite.+ Default: False+ manual: True++Flag postgresql+ Description: test postgresql. default is to test just sqlite.+ Default: False+ manual: True++Flag mysql+ Description: test MySQL. default is to test just sqlite.+ Default: False+ manual: True++Flag high_precision_date+ Description: for MongoDB use a time storage with nano second precision.+ Default: False+ manual: True++flag nooverlap+ default: False+ description: test out our assumption that OverlappingInstances is just for String+ manual: True++library+ exposed-modules: PersistentTest+ PersistTestPetType+ PersistTestPetCollarType+ RenameTest+ DataTypeTest+ EmptyEntityTest+ HtmlTest+ EmbedTest+ EmbedOrderTest+ EntityEmbedTest+ LargeNumberTest+ UniqueTest+ MaxLenTest+ Recursive+ SumTypeTest+ MigrationOnlyTest+ MigrationTest+ MigrationIdempotencyTest+ PersistUniqueTest+ CompositeTest+ Init+ PrimaryTest+ CustomPersistField+ CustomPersistFieldTest+ CustomPrimaryKeyReferenceTest+ InsertDuplicateUpdate+ MigrationColumnLengthTest+ EquivalentTypeTest++ hs-source-dirs: src, test++ ghc-options: -Wall+ if impl(ghc >= 7.8)+ ghc-options: -Wall -j++ build-depends: base >= 4.6 && < 5+ , persistent+ , persistent-template+ , HUnit+ , hspec >= 1.12.1+ , hspec-expectations+ , template-haskell+ , aeson >= 0.7+ , aeson-compat >= 0.3.2.0 && < 0.4+ , lifted-base >= 0.1+ , network+ , path-pieces >= 0.1+ , http-api-data >= 0.2+ , text >= 0.8+ , transformers >= 0.2.1+ , unliftio-core+ , unliftio+ , containers >= 0.2+ , bytestring >= 0.9+ , base64-bytestring+ , conduit >= 1.0+ , resourcet >= 0.4+ , exceptions >= 0.6+ , time >= 1.1.4+ , random >= 1.0+ , QuickCheck >= 2.7+ , blaze-html >= 0.5+ , blaze-markup >= 0.5.1+ , quickcheck-instances >= 0.3+ , transformers-base+ , attoparsec+ , vector+ , unordered-containers+ , monad-logger >= 0.3+ , hashable+ -- actually just a mongoDB dependency+ -- fixes build warning on current build server+ , cereal+ , silently+ , blaze-builder+ , mtl+ , fast-logger+ , semigroups+ , scientific+ , resource-pool+ , exceptions+ , tagged+ , old-locale++ if flag(nooverlap)+ cpp-options: -DNO_OVERLAP++ if !flag(postgresql) && !flag(mysql) && !flag(mongodb) && !flag(zookeeper)+ build-depends: persistent-sqlite >= 2.6.1.1+ cpp-options: -DWITH_SQLITE -DDEBUG++ if flag(postgresql)+ build-depends: persistent-postgresql+ , postgresql-simple+ , postgresql-libpq+ cpp-options: -DWITH_POSTGRESQL -DDEBUG++ if flag(mysql)+ build-depends: persistent-mysql+ , mysql-simple >= 0.4.3 && < 0.5+ , mysql >= 0.1.1.3 && < 0.2+ cpp-options: -DWITH_MYSQL++ if flag(mongodb)+ build-depends: persistent-mongoDB+ , mongoDB >= 2.0.4 && < 3.0+ , cereal+ , bson >= 0.3.1+ , process+ cpp-options: -DWITH_NOSQL -DWITH_MONGODB -DDEBUG++ if flag(zookeeper)+ build-depends: persistent-zookeeper+ , hzk >= 2.1.0+ , binary+ , utf8-string >= 0.3.7 && < 0.4.0+ , process+ cpp-options: -DWITH_NOSQL -DWITH_ZOOKEEPER -DDEBUG++ if flag(high_precision_date)+ cpp-options: -DHIGH_PRECISION_DATE++ default-language: Haskell2010+++executable persistent-test+ main-is: main.hs+ hs-source-dirs: test+ default-language: Haskell2010++ build-depends: base >= 4.6 && < 5+ , persistent-test+ , persistent+ , hspec+ , system-filepath+ , system-fileio+ , resourcet+ , scientific++ if !flag(postgresql) && !flag(mysql) && !flag(mongodb) && !flag(zookeeper)+ cpp-options: -DWITH_SQLITE -DDEBUG+ if flag(zookeeper)+ cpp-options: -DWITH_NOSQL -DWITH_ZOOKEEPER -DDEBUG+ if flag(mongodb)+ cpp-options: -DWITH_NOSQL -DWITH_MONGODB -DDEBUG+ if flag(postgresql)+ cpp-options: -DWITH_POSTGRESQL+ if flag(mysql)+ cpp-options: -DWITH_MYSQL+++source-repository head+ type: git+ location: git://github.com/yesodweb/persistent.git
+ src/CompositeTest.hs view
@@ -0,0 +1,311 @@+{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-orphans #-}+{-# LANGUAGE UndecidableInstances #-} -- FIXME+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+module CompositeTest where++import Test.Hspec.Expectations ()+import Init++#ifndef WITH_NOSQL+import Data.Maybe (isJust)+import Database.Persist.TH (mkDeleteCascade)+#endif+++-- mpsGeneric = False is due to a bug or at least lack of a feature in mkKeyTypeDec TH.hs+#if WITH_NOSQL+mkPersist persistSettings { mpsGeneric = False } [persistUpperCase|+#else+share [mkPersist persistSettings { mpsGeneric = False }, mkMigrate "compositeMigrate", mkDeleteCascade persistSettings { mpsGeneric = False }] [persistLowerCase|+#endif+ TestParent+ name String maxlen=20+ name2 String maxlen=20+ age Int+ extra44 String+ Primary name name2 age+ deriving Show Eq+ TestChild+ name String maxlen=20+ name2 String maxlen=20+ age Int+ extra4 String+ Foreign TestParent fkparent name name2 age+ deriving Show Eq+#ifndef WITH_MYSQL+ Tree+ name Text+ parent Text Maybe+ Primary name+ Foreign Tree fkparent parent+#endif++ Citizen+ name String+ age Int Maybe+ deriving Eq Show+ Address+ address String+ country String+ deriving Eq Show+ CitizenAddress+ citizen CitizenId+ address AddressId+ Primary citizen address+ deriving Eq Show++ PrimaryCompositeWithOtherNullableFields+ foo String maxlen=20+ bar String maxlen=20+ baz String Maybe+ Primary foo bar+ deriving Eq Show+|]+++#ifdef WITH_NOSQL+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])++db :: Action IO () -> Assertion+db = db' cleanDB++specs :: Spec+specs = return ()+#else++specs :: Spec+specs = 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'"++ it "insertWithKey" $ db $ do+ kp1 <- insert p1+ delete kp1+ insertKey kp1 p2++ it "repsert" $ db $ do+ kp1 <- insert p1+ repsert kp1 p2++ it "Insert" $ db $ 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" $ db $ do+ kp1 <- insert p1+ kp2 <- insert p2+ xs <- selectList [TestParentId <-. [kp1,kp2]] []+ length xs @== 2+ let [e1@(Entity newkp1 newp1),e2@(Entity newkp2 newp2)] = xs+ matchParentK kp1 @== matchParentK newkp1+ matchParentK kp2 @== matchParentK newkp2+ p1 @== newp1+ p2 @== newp2++ it "Filter by Id with 'not equal'" $ db $ 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'" $ db $ 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'" $ db $ 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" $ db $ do+ kp1 <- insert p1+ kp2 <- insert p2+ xs <- selectList [TestParentId /<-. [kp1,kp2]] []+ length xs @== 0++ it "Extract Parent Foreign Key from Child value" $ db $ do+ kp1 <- insert p1+ _ <- insert p2+ kc1 <- insert c1+ mc <- get kc1+ isJust mc @== True+ let Just c11 = mc+ c1 @== c11+ testChildFkparent c11 @== kp1++#ifndef WITH_MYSQL+ it "Tree relationships" $ db $ do+ kgp@(TreeKey gpt) <- insert $ Tree "grandpa" Nothing+ kdad@(TreeKey dadt) <- insert $ Tree "dad" $ Just gpt+ kc <- insert $ Tree "child" $ Just dadt+ c <- getJust kc+ treeFkparent c @== Just kdad+ dad <- getJust kdad+ treeFkparent dad @== Just kgp+ gp <- getJust kgp+ treeFkparent gp @== Nothing+#endif++ it "Validate Key contents" $ db $ 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" $ db $ do+ kp1 <- insert p1+ kp2 <- insert p2++ _ <- delete kp1+ r <- get kp1+ r @== Nothing+ r1 <- get kp2+ isJust r1 @== True++ it "Update" $ db $ do+ kp1 <- insert p1+ _ <- update kp1 [TestParentExtra44 =. "q1"]+ newkps1 <- get kp1+ newkps1 @== Just (TestParent "a1" "b1" 11 "q1")++ it "Replace Parent" $ db $ do+ kp1 <- insert p1+ _ <- replace kp1 p1'+ newp1 <- get kp1+ newp1 @== Just p1'++ it "Replace Child" $ db $ do+ -- c1 FKs p1+ _ <- insert p1+ kc1 <- insert c1+ _ <- replace kc1 c1'+ newc1 <- get kc1+ newc1 @== Just c1'++ it "Insert Many to Many" $ db $ 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++ 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++ xs <- selectList [CitizenAddressId ==. kca1] []+ length xs @== 1+ let [Entity newkca1 newca2] = xs+ matchCitizenAddressK kca1 @== matchCitizenAddressK newkca1+ ca1 @== newca2+ it "insertMany" $ db $ do+ [kp1, kp2] <- insertMany [p1, p2]+ newp1 <- get kp1+ newp1 @== Just p1++ newp2 <- get kp2+ newp2 @== Just p2+ it "RawSql Key instance" $ db $ do+ key <- insert p1+ keyFromRaw <- rawSql "SELECT name, name2, age FROM test_parent LIMIT 1" []+ [key] @== keyFromRaw++ it "RawSql Key instance with sqlQQ" $ db $ do+ key <- insert p1+ keyFromRaw' <- [sqlQQ|+ SELECT @{TestParentName}, @{TestParentName2}, @{TestParentAge}+ FROM ^{TestParent}+ LIMIT 1+ |]+ [key] @== keyFromRaw'++ it "RawSql Entity instance" $ db $ do+ key <- insert p1+ newp1 <- rawSql "SELECT ?? FROM test_parent LIMIT 1" []+ [Entity key p1] @== newp1++ it "RawSql Entity instance with sqlQQ" $ db $ do+ key <- insert p1+ newp1' <- [sqlQQ| SELECT ?? FROM ^{TestParent} |]+ [Entity key p1] @== newp1'++#endif++matchK :: (PersistField a, PersistEntity record) => Key record -> Either Text a+matchK = (\(pv:[]) -> fromPersistValue pv) . keyToValues++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++matchCitizenAddressK :: Key CitizenAddress -> Either Text (Int64, Int64)+matchCitizenAddressK = (\(a:b:[]) -> (,) <$> fromPersistValue a <*> fromPersistValue b)+ . keyToValues
+ src/CustomPersistField.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, FlexibleInstances, EmptyDataDecls, MultiParamTypeClasses #-}++-- 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+module CustomPersistField where++import Init+import Data.Text (pack)+import qualified Data.Text.Lazy as TL+import Data.Text.Lazy (toStrict, fromStrict)+import Data.String (IsString)++newtype Markdown = Markdown TL.Text+ 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."+++instance PersistFieldSql Markdown where+ sqlType _ = SqlString
+ src/CustomPersistFieldTest.hs view
@@ -0,0 +1,33 @@+{-# OPTIONS_GHC -fno-warn-unused-binds #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, FlexibleInstances, EmptyDataDecls, MultiParamTypeClasses #-}++module CustomPersistFieldTest (+ specs+#ifndef WITH_NOSQL+ , customFieldMigrate+#endif+) where++import Init+import CustomPersistField++#ifdef WITH_NOSQL+db :: Action IO () -> Assertion+db = db' (return ())+mkPersist persistSettings [persistUpperCase|+#else+share [mkPersist sqlSettings, mkMigrate "customFieldMigrate"] [persistLowerCase|+#endif+ BlogPost+ article Markdown+ deriving Show Eq+|]++specs :: Spec+specs = describe "Custom persist field" $ do+ it "should read what it wrote" $ db $ do+ let originalBlogPost = BlogPost "article"+ blogPostId <- insert originalBlogPost+ Just newBlogPost <- get blogPostId+ liftIO $ originalBlogPost @?= newBlogPost+
+ src/CustomPrimaryKeyReferenceTest.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}++-- 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++import Init++-- mpsGeneric = False is due to a bug or at least lack of a feature in mkKeyTypeDec TH.hs+#if WITH_NOSQL+mkPersist persistSettings { mpsGeneric = False } [persistUpperCase|+#else+share [mkPersist persistSettings { mpsGeneric = False }, mkMigrate "migration"] [persistLowerCase|+#endif+ Tweet+ tweetId Int+ statusText Text sqltype=varchar(170)+ Primary tweetId+ UniqueTweetId tweetId+ deriving Show+ TweetUrl+ tweetId TweetId+ tweetUrl Text sqltype=varchar(255)+ finalUrl Text Maybe sqltype=varchar(255)+ UniqueTweetIdTweetUrl tweetId tweetUrl+ deriving Show+|]+#ifdef WITH_NOSQL+cleanDB :: (MonadIO m, PersistQuery backend, PersistEntityBackend Tweet ~ backend) => ReaderT backend m ()+cleanDB = do+ deleteWhere ([] :: [Filter Tweet])+ deleteWhere ([] :: [Filter TweetUrl])++db :: Action IO () -> Assertion+db = db' cleanDB+#endif++specs :: Spec+specs = describe "custom primary key reference" $ do+#ifdef WITH_NOSQL+ return ()+#else++ let tweet = Tweet {tweetTweetId = 1, tweetStatusText = "Hello!"}++ it "can insert a Tweet" $ db $ do+ tweetId <- insert tweet+ let url = TweetUrl {tweetUrlTweetId = tweetId, tweetUrlTweetUrl = "http://google.com", tweetUrlFinalUrl = Just "http://example.com"}+ insert_ url++ return ()++#endif
+ src/DataTypeTest.hs view
@@ -0,0 +1,198 @@+{-# OPTIONS_GHC -fno-warn-unused-binds #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}+module DataTypeTest (specs) where++import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)+import Test.QuickCheck.Gen (Gen(..))+import Test.QuickCheck.Instances ()+import Test.QuickCheck.Random (newQCGen)+import Database.Persist.TH+import Data.Char (generalCategory, GeneralCategory(..))+import qualified Data.Text as T+import qualified Data.ByteString as BS+import Data.Time (Day, UTCTime (..), fromGregorian, picosecondsToDiffTime,+ TimeOfDay (TimeOfDay), timeToTimeOfDay, timeOfDayToTime)+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime)+import Data.IntMap (IntMap)+import Data.Fixed (Pico,Micro)++import Init++type Tuple a b = (a, b)++#ifdef WITH_NOSQL+mkPersist persistSettings [persistUpperCase|+#else+-- Test lower case names+share [mkPersist persistSettings, mkMigrate "dataTypeMigrate"] [persistLowerCase|+#endif+DataTypeTable no-json+ text Text+ textMaxLen Text maxlen=100+ bytes ByteString+ bytesTextTuple (Tuple ByteString Text)+ bytesMaxLen ByteString maxlen=100+ int Int+ intList [Int]+ intMap (IntMap Int)+ double Double+ bool Bool+ day Day+#ifndef WITH_NOSQL+ pico Pico+ time TimeOfDay+#endif+ utc UTCTime+#if defined(WITH_MYSQL) && !(defined(OLD_MYSQL))+ -- For MySQL, provide extra tests for time fields with fractional seconds,+ -- since the default (used above) is to have no fractional part. This+ -- requires the server version to be at least 5.6.4, and should be switched+ -- off for older servers by defining OLD_MYSQL.+ timeFrac TimeOfDay sqltype=TIME(6)+ utcFrac UTCTime sqltype=DATETIME(6)+#endif+|]++cleanDB :: (MonadIO m, PersistQuery backend, backend ~ PersistEntityBackend DataTypeTable) => ReaderT backend m ()+cleanDB = deleteWhere ([] :: [Filter DataTypeTable])++specs :: Spec+specs = describe "data type specs" $+ it "handles all types" $ asIO $ runConn $ do+#ifndef WITH_NOSQL+ _ <- runMigrationSilent dataTypeMigrate+ -- Ensure reading the data from the database works...+ _ <- runMigrationSilent dataTypeMigrate+#endif+ rvals <- liftIO randomValues+ forM_ (take 1000 rvals) $ \x -> do+ key <- insert x+ Just y <- get key+ liftIO $ do+ let check :: (Eq a, Show a) => String -> (DataTypeTable -> a) -> IO ()+ check s f = (s, f x) @=? (s, f y)+ -- Check floating-point near equality+ let check' :: String -> (DataTypeTable -> Pico) -> 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+ check "text" dataTypeTableText+ check "textMaxLen" dataTypeTableTextMaxLen+ check "bytes" dataTypeTableBytes+ check "bytesTextTuple" dataTypeTableBytesTextTuple+ check "bytesMaxLen" dataTypeTableBytesMaxLen+ check "int" dataTypeTableInt+ check "intList" dataTypeTableIntList+ check "intMap" dataTypeTableIntMap+ check "bool" dataTypeTableBool+ check "day" dataTypeTableDay+#ifndef WITH_NOSQL+ check' "pico" dataTypeTablePico+ check "time" (roundTime . dataTypeTableTime)+#endif+#if !(defined(WITH_NOSQL)) || (defined(WITH_NOSQL) && defined(HIGH_PRECISION_DATE))+ check "utc" (roundUTCTime . dataTypeTableUtc)+#endif+#if defined(WITH_MYSQL) && !(defined(OLD_MYSQL))+ check "timeFrac" (dataTypeTableTimeFrac)+ check "utcFrac" (dataTypeTableUtcFrac)+#endif++ -- Do a special check for Double since it may+ -- lose precision when serialized.+ when (getDoubleDiff (dataTypeTableDouble x)(dataTypeTableDouble y) > 1e-14) $+ check "double" dataTypeTableDouble+ 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)++roundFn :: RealFrac a => a -> Integer+#ifdef OLD_MYSQL+-- At version 5.6.4, MySQL changed the method used to round values for+-- date/time types - this is the same version which added support for+-- fractional seconds in the storage type.+roundFn = truncate+#else+roundFn = round+#endif++roundTime :: TimeOfDay -> TimeOfDay+#ifdef WITH_MYSQL+roundTime t = timeToTimeOfDay $ fromIntegral $ roundFn $ timeOfDayToTime t+#else+roundTime = id+#endif++roundUTCTime :: UTCTime -> UTCTime+#ifdef WITH_MYSQL+roundUTCTime t =+ posixSecondsToUTCTime $ fromIntegral $ roundFn $ utcTimeToPOSIXSeconds t+#else+roundUTCTime = id+#endif++randomValues :: IO [DataTypeTable]+randomValues = do+ g <- newQCGen+ return $ map (unGen arbitrary g) [0..]++instance Arbitrary DataTypeTable where+ arbitrary = DataTypeTable+ <$> arbText -- text+ <*> (T.take 100 <$> arbText) -- textManLen+ <*> arbitrary -- bytes+ <*> arbTuple arbitrary arbText -- bytesTextTuple+ <*> (BS.take 100 <$> arbitrary) -- bytesMaxLen+ <*> arbitrary -- int+ <*> arbitrary -- intList+ <*> arbitrary -- intMap+ <*> arbitrary -- double+ <*> arbitrary -- bool+ <*> arbitrary -- day+#ifndef WITH_NOSQL+ <*> arbitrary -- pico+ <*> (truncateTimeOfDay =<< arbitrary) -- time+#endif+ <*> (truncateUTCTime =<< arbitrary) -- utc+#if defined(WITH_MYSQL) && !(defined(OLD_MYSQL))+ <*> (truncateTimeOfDay =<< arbitrary) -- timeFrac+ <*> (truncateUTCTime =<< arbitrary) -- utcFrac+#endif++arbText :: Gen Text+arbText =+ T.pack+ . filter ((`notElem` forbidden) . generalCategory)+ . filter (<= '\xFFFF') -- only BMP+ . filter (/= '\0') -- no nulls+ <$> arbitrary+ where forbidden = [NotAssigned, PrivateUse]++arbTuple :: Gen a -> Gen b -> Gen (a, b)+arbTuple x y = (,) <$> x <*> y++-- truncate less significant digits+truncateToMicro :: Pico -> Pico+truncateToMicro p = let+ p' = fromRational . toRational $ p :: Micro+ in fromRational . toRational $ p' :: Pico++truncateTimeOfDay :: TimeOfDay -> Gen TimeOfDay+truncateTimeOfDay (TimeOfDay h m s) =+ return $ TimeOfDay h m $ truncateToMicro s++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++asIO :: IO a -> IO a+asIO = id
+ src/EmbedOrderTest.hs view
@@ -0,0 +1,72 @@+{-# OPTIONS_GHC -fno-warn-unused-binds #-}+{-# LANGUAGE CPP, ScopedTypeVariables, FlexibleInstances #-}+{-# LANGUAGE QuasiQuotes, TypeFamilies, GeneralizedNewtypeDeriving, TemplateHaskell,+ OverloadedStrings, GADTs, FlexibleContexts, EmptyDataDecls, MultiParamTypeClasses #-}+module EmbedOrderTest (specs,+#ifndef WITH_NOSQL+embedOrderMigrate+#endif+) where++import Init+import Data.Map hiding (insert)++import Debug.Trace (trace)+debug :: Show s => s -> s+debug x = trace (show x) x++#if WITH_NOSQL+mkPersist persistSettings [persistUpperCase|+#else+share [mkPersist sqlSettings, mkMigrate "embedOrderMigrate"] [persistUpperCase|+#endif+Foo sql=foo_embed_order+ bars [Bar]+ deriving Eq Show+Bar sql=bar_embed_order+ b String+ u String+ g String+ deriving Eq Show+|]++#ifdef WITH_NOSQL+cleanDB :: (PersistQuery backend, PersistEntityBackend Foo ~ backend, MonadIO m) => ReaderT backend m ()+cleanDB = do+ deleteWhere ([] :: [Filter Foo])+ deleteWhere ([] :: [Filter Bar])++db :: Action IO () -> Assertion+db = db' cleanDB+#endif++specs :: Spec+specs = describe "embedded entities" $ do+ it "preserves ordering" $ db $ do+ let foo = Foo [Bar "b" "u" "g"]+ fooId <- insert foo+ Just otherFoo <- get fooId+ foo @== otherFoo++ it "PersistMap PersistValue serializaion" $ db $ do+ let record = fromList [("b","b"),("u","u"),("g","g")] :: Map Text Text+ record @== (fromRight . fromPersistValue . toPersistValue) record++ -- this demonstrates a change in ordering+ -- that won't be a problem if the keys are properly tracked+ {-+ let precord = PersistMap [("b",PersistText "b"),("u",PersistText "u"),("g",PersistText "g")]+ precord ==@ (debug . toPersistValue . debug . (fromRight . fromPersistValue :: PersistValue -> Map Text Text)) precord++ let precord = PersistMap [("b",PersistText "b"),("u",PersistText "u"),("g",PersistText "g")]+ precord ==@ (fromSuccess . fromJSON . debug . (toJSON :: PersistValue -> Value)) precord+++fromSuccess :: Result a -> a+fromSuccess (Success s) = s+fromSuccess (Error e) = error $ "expected Success, got Error " ++ e+ -}++fromRight :: Show a => Either a b -> b+fromRight (Left e) = error $ "expected Right, got Left " ++ show e+fromRight (Right x) = x
+ src/EmbedTest.hs view
@@ -0,0 +1,443 @@+{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-orphans -O0 #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}+module EmbedTest (specs,+#ifndef WITH_NOSQL+embedMigrate+#endif+) where++import Init+import Control.Exception (Exception, throw)+import Data.Typeable (Typeable)++import qualified Data.Text as T+import qualified Data.Set as S+import qualified Data.Map as M+#if WITH_NOSQL+#ifdef WITH_MONGODB+import Database.Persist.MongoDB+import Database.MongoDB (genObjectId)+import Database.MongoDB (Value(String))+#endif+import EntityEmbedTest+import System.Process (readProcess)+#endif+import Data.List.NonEmpty hiding (insert, length)++data TestException = TestException+ deriving (Show, Typeable, Eq)+instance Exception TestException++instance PersistFieldSql a => PersistFieldSql (NonEmpty a) where+ sqlType _ = SqlString+instance PersistField a => PersistField (NonEmpty a) where+ toPersistValue = toPersistValue . toList+ fromPersistValue pv = case fromPersistValue pv of+ Left e -> Left e+ Right [] -> Left "PersistField: NonEmpty found unexpected Empty List"+ Right (l:ls) -> Right (l:|ls)+++#if WITH_NOSQL+mkPersist persistSettings [persistUpperCase|+# ifdef WITH_MONGODB+ HasObjectId+ oid ObjectId+ name Text+ deriving Show Eq Read Ord++ HasArrayWithObjectIds+ name Text+ arrayWithObjectIds [HasObjectId]+ deriving Show Eq Read Ord++ HasArrayWithEntities+ hasEntity (Entity ARecord)+ arrayWithEntities [AnEntity]+ deriving Show Eq Read Ord+# endif++#else+share [mkPersist sqlSettings, mkMigrate "embedMigrate"] [persistUpperCase|+#endif++ OnlyName+ name Text+ deriving Show Eq Read Ord++ HasEmbed+ name Text+ embed OnlyName+ deriving Show Eq Read Ord++ HasEmbeds+ name Text+ embed OnlyName+ double HasEmbed+ deriving Show Eq Read Ord++ HasListEmbed+ name Text+ list [HasEmbed]+ deriving Show Eq Read Ord++ HasSetEmbed+ name Text+ set (S.Set HasEmbed)+ deriving Show Eq Read Ord++ HasMap+ name Text+ map (M.Map T.Text T.Text)+ deriving Show Eq Read Ord++ HasList+ list [HasListId]+ deriving Show Eq Read Ord++ EmbedsHasMap+ name Text Maybe+ embed HasMap+ deriving Show Eq Read Ord++ InList+ one Int+ two Int+ deriving Show Eq++ ListEmbed+ nested [InList]+ one Int+ two Int+ deriving Show Eq++ User+ ident Text+ password Text Maybe+ profile Profile+ deriving Show Eq Read Ord++ Profile+ firstName Text+ lastName Text+ contact Contact Maybe+ deriving Show Eq Read Ord++ Contact+ phone Int+ email T.Text+ deriving Show Eq Read Ord++ Account+ userIds (NonEmpty (Key User))+ name Text Maybe+ customDomains [Text] -- we may want to allow multiple cust domains. use [] instead of maybe++ deriving Show Eq Read Ord++ HasNestedList+ list [IntList]+ deriving Show Eq++ IntList+ ints [Int]+ deriving Show Eq++ -- We would like to be able to use OnlyNameId+ -- But (Key OnlyName) works+ MapIdValue+ map (M.Map T.Text (Key OnlyName))+ deriving Show Eq Read Ord+++ -- Self refrences are only allowed as a nullable type:+ -- a Maybe or a List+ SelfList+ reference [SelfList]++ SelfMaybe+ reference SelfMaybe Maybe++ -- This failes+ -- SelfDirect+ -- reference SelfDirect+|]+#ifdef WITH_NOSQL+cleanDB :: (PersistQuery backend, PersistEntityBackend HasMap ~ backend, MonadIO m) => ReaderT backend m ()+cleanDB = do+ deleteWhere ([] :: [Filter HasEmbed])+ deleteWhere ([] :: [Filter HasEmbeds])+ deleteWhere ([] :: [Filter HasListEmbed])+ deleteWhere ([] :: [Filter HasSetEmbed])+ deleteWhere ([] :: [Filter User])+ deleteWhere ([] :: [Filter HasMap])+ deleteWhere ([] :: [Filter HasList])+ deleteWhere ([] :: [Filter EmbedsHasMap])+ deleteWhere ([] :: [Filter ListEmbed])+ deleteWhere ([] :: [Filter ARecord])+ deleteWhere ([] :: [Filter Account])+ deleteWhere ([] :: [Filter HasNestedList])++db :: Action IO () -> Assertion+db = db' cleanDB+#endif++unlessM :: MonadIO m => IO Bool -> m () -> m ()+unlessM predicate body = do+ b <- liftIO predicate+ unless b body++specs :: Spec+specs = describe "embedded entities" $ do++ it "simple entities" $ db $ 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" $ db $ do+ let container = HasEmbed "container" (OnlyName "2")+ contK <- insert container+ Just res <- selectFirst [HasEmbedEmbed ==. OnlyName "2"] []+ res @== Entity contK container++ it "Set" $ db $ 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" $ db $ 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) $ db $ 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" $ db $ 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" $ db $ do+ let container = HasListEmbed "list empty" []+ contK <- insert container+ Just res <- selectFirst [HasListEmbedName ==. "list empty"] []+ res @== Entity contK container++ it "List empty" $ db $ do+ let container = HasList []+ contK <- insert container+ Just res <- selectFirst [] []+ res @== Entity contK container++ it "NonEmpty List wrapper" $ db $ 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" $ db $ 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" $ db $ do+ let container = HasMap "empty" $ M.fromList []+ contK <- insert container+ Just res <- selectFirst [HasMapName ==. "empty"] []+ res @== Entity contK container++ it "Embeds a Map" $ db $ 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" $ db $ 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" $ db $ 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++#ifdef WITH_NOSQL+#ifdef WITH_MONGODB+ it "List" $ db $ do+ k1 <- insert $ HasList []+ k2 <- insert $ HasList [k1]+ let container = HasList [k1, k2]+ contK <- insert container+ Just res <- selectFirst [HasListList `anyEq` k2] []+ res @== Entity contK container++ it "can embed an Entity" $ db $ do+ let foo = ARecord "foo"+ bar = ARecord "bar"+ _ <- insertMany [foo, bar]+ arecords <- selectList ([ARecordName ==. "foo"] ||. [ARecordName ==. "bar"]) []+ length arecords @== 2++ kfoo <- insert foo+ let hasEnts = HasArrayWithEntities (Entity kfoo foo) arecords+ kEnts <- insert hasEnts+ Just retrievedHasEnts <- get kEnts+ retrievedHasEnts @== hasEnts++ it "can embed objects with ObjectIds" $ db $ do+ oid <- liftIO $ genObjectId+ let hoid = HasObjectId oid "oid"+ hasArr = HasArrayWithObjectIds "array" [hoid]++ k <- insert hasArr+ Just v <- get k+ v @== hasArr++ describe "mongoDB filters" $ do+ it "mongo single nesting filters" $ db $ do+ let usr = User "foo" (Just "pswd") prof+ prof = Profile "fstN" "lstN" (Just con)+ con = Contact 123456 "foo@bar.com"+ uId <- insert usr+ Just r1 <- selectFirst [UserProfile &->. ProfileFirstName `nestEq` "fstN"] []+ r1 @== (Entity uId usr)+ Just r2 <- selectFirst [UserProfile &~>. ProfileContact ?&->. ContactEmail `nestEq` "foo@bar.com", UserIdent ==. "foo"] []+ r2 @== (Entity uId usr)++ it "mongo embedded array filters" $ db $ do+ let container = HasListEmbed "list" [+ (HasEmbed "embed" (OnlyName "1"))+ , (HasEmbed "embed" (OnlyName "2"))+ ]+ contK <- insert container+ let contEnt = Entity contK container+ Just meq <- selectFirst [HasListEmbedList `anyEq` HasEmbed "embed" (OnlyName "1")] []+ meq @== contEnt++ Just neq1 <- selectFirst [HasListEmbedList ->. HasEmbedName `nestEq` "embed"] []+ neq1 @== contEnt++ Just nne1 <- selectFirst [HasListEmbedList ->. HasEmbedName `nestNe` "notEmbed"] []+ nne1 @== contEnt++ Just neq2 <- selectFirst [HasListEmbedList ~>. HasEmbedEmbed &->. OnlyNameName `nestEq` "1"] []+ neq2 @== contEnt++ Just nbq1 <- selectFirst [HasListEmbedList ->. HasEmbedName `nestBsonEq` String "embed"] []+ nbq1 @== contEnt++ Just nbq2 <- selectFirst [HasListEmbedList ~>. HasEmbedEmbed &->. OnlyNameName `nestBsonEq` String "1"] []+ nbq2 @== contEnt++ it "regexp match" $ db $ do+ let container = HasListEmbed "list" [+ (HasEmbed "embed" (OnlyName "abcd"))+ , (HasEmbed "embed" (OnlyName "efgh"))+ ]+ contK <- insert container+ let mkReg t = (t, "ims")+ Just res <- selectFirst [HasListEmbedName =~. mkReg "ist"] []+ res @== (Entity contK container)++ it "nested anyEq" $ db $ do+ let top = HasNestedList [IntList [1,2]]+ k <- insert top+ Nothing <- selectFirst [HasNestedListList ->. IntListInts `nestEq` ([]::[Int])] []+ Nothing <- selectFirst [HasNestedListList ->. IntListInts `nestAnyEq` 3] []+ Just res <- selectFirst [HasNestedListList ->. IntListInts `nestAnyEq` 2] []+ res @== (Entity k top)++ describe "mongoDB updates" $ do+ it "mongo single nesting updates" $ db $ do+ let usr = User "foo" (Just "pswd") prof+ prof = Profile "fstN" "lstN" (Just con)+ con = Contact 123456 "foo@bar.com"+ uid <- insert usr+ let newName = "fstN2"+ usr1 <- updateGet uid [UserProfile &->. ProfileFirstName `nestSet` newName]+ (profileFirstName $ userProfile usr1) @== newName++ let newEmail = "foo@example.com"+ let newIdent = "bar"+ usr2 <- updateGet uid [UserProfile &~>. ProfileContact ?&->. ContactEmail `nestSet` newEmail, UserIdent =. newIdent]+ (userIdent usr2) @== newIdent+ (fmap contactEmail . profileContact . userProfile $ usr2) @== Just newEmail+++ it "mongo embedded array updates" $ db $ do+ let container = HasListEmbed "list" [+ (HasEmbed "embed" (OnlyName "1"))+ , (HasEmbed "embed" (OnlyName "2"))+ ]+ contk <- insert container+ let contEnt = Entity contk container++ pushed <- updateGet contk [HasListEmbedList `push` HasEmbed "embed" (OnlyName "3")]+ (Prelude.map (onlyNameName . hasEmbedEmbed) $ hasListEmbedList pushed) @== ["1","2","3"]++ -- same, don't add anything+ addedToSet <- updateGet contk [HasListEmbedList `addToSet` HasEmbed "embed" (OnlyName "3")]+ (Prelude.map (onlyNameName . hasEmbedEmbed) $ hasListEmbedList addedToSet) @== ["1","2","3"]+ pulled <- updateGet contk [HasListEmbedList `pull` HasEmbed "embed" (OnlyName "3")]+ (Prelude.map (onlyNameName . hasEmbedEmbed) $ hasListEmbedList pulled) @== ["1","2"]++ -- now it is new+ addedToSet2 <- updateGet contk [HasListEmbedList `addToSet` HasEmbed "embed" (OnlyName "3")]+ (Prelude.map (onlyNameName . hasEmbedEmbed) $ hasListEmbedList addedToSet2) @== ["1","2","3"]++ allPulled <- updateGet contk [eachOp pull HasListEmbedList+ [ HasEmbed "embed" (OnlyName "3")+ , HasEmbed "embed" (OnlyName "2")+ ] ]+ (Prelude.map (onlyNameName . hasEmbedEmbed) $ hasListEmbedList allPulled) @== ["1"]+ allPushed <- updateGet contk [eachOp push HasListEmbedList+ [ HasEmbed "embed" (OnlyName "4")+ , HasEmbed "embed" (OnlyName "5")+ ] ]+ (Prelude.map (onlyNameName . hasEmbedEmbed) $ hasListEmbedList allPushed) @== ["1","4","5"]+++ it "re-orders json inserted from another source" $ db $ do+ let cname = T.unpack $ collectionName (error "ListEmbed" :: ListEmbed)+ liftIO $ putStrLn =<< readProcess "mongoimport" ["-d", T.unpack dbName, "-c", cname] "{ \"nested\": [{ \"one\": 1, \"two\": 2 }, { \"two\": 2, \"one\": 1}], \"two\": 2, \"one\": 1, \"_id\" : { \"$oid\" : \"50184f5a92d7ae0000001e89\" } }"+ -- liftIO $ putStrLn =<< readProcess "mongo" ["--eval", "printjson(db." ++ cname ++ ".find().toArray())", T.unpack dbName] ""++ lists <- selectList [] []+ fmap entityVal lists @== [ListEmbed [InList 1 2, InList 1 2] 1 2]+#endif+#endif
+ src/EmptyEntityTest.hs view
@@ -0,0 +1,36 @@+{-# OPTIONS_GHC -fno-warn-unused-binds #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}+module EmptyEntityTest (specs) where++import Database.Persist.Sql+import Database.Persist.TH+import Control.Monad.Trans.Resource (runResourceT)++import Init++#ifdef WITH_NOSQL+mkPersist persistSettings [persistUpperCase|+#else+-- Test lower case names+share [mkPersist sqlSettings, mkMigrate "dataTypeMigrate"] [persistLowerCase|+#endif+EmptyEntity+|]++#ifdef WITH_NOSQL+cleanDB :: MonadIO m => ReaderT Context m ()+cleanDB = deleteWhere ([] :: [Filter EmptyEntity])+#endif++specs :: Spec+specs = describe "empty entity" $+ it "inserts" $ (id :: IO () -> IO ()) $ runResourceT $ runConn $ do+#ifndef WITH_NOSQL+ _ <- runMigrationSilent dataTypeMigrate+ -- Ensure reading the data from the database works...+ _ <- runMigrationSilent dataTypeMigrate+#endif+ x <- insert EmptyEntity+ Just EmptyEntity <- get x+ return ()
+ src/EntityEmbedTest.hs view
@@ -0,0 +1,18 @@+{-# OPTIONS_GHC -fno-warn-unused-binds #-}+{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}+{-# LANGUAGE DeriveDataTypeable #-}+module EntityEmbedTest where++-- because we are using a type alias we need to declare in a separate module+-- this is used in EmbedTest+#if WITH_NOSQL+import Init++mkPersist persistSettings [persistUpperCase|+ ARecord+ name Text+ deriving Show Eq Read Ord+|]++type AnEntity = Entity ARecord+#endif
+ src/EquivalentTypeTest.hs view
@@ -0,0 +1,61 @@+{-# OPTIONS_GHC -fno-warn-unused-binds #-}+{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module EquivalentTypeTest (specs) where++import Database.Persist.TH+import Control.Monad.Trans.Resource (runResourceT)+#ifdef WITH_POSTGRESQL+import qualified Data.Text as T+#endif++import Init++#ifdef WITH_NOSQL+mkPersist persistSettings [persistUpperCase|+#else+share [mkPersist sqlSettings, mkMigrate "migrateAll1"] [persistLowerCase|+#endif+EquivalentType sql=equivalent_types+ field1 Int+#ifdef WITH_POSTGRESQL+ field2 T.Text sqltype=text+ field3 T.Text sqltype=us_postal_code+#endif+ deriving Eq Show+|]++#ifdef WITH_NOSQL+mkPersist persistSettings [persistUpperCase|+#else+share [mkPersist sqlSettings, mkMigrate "migrateAll2"] [persistLowerCase|+#endif+EquivalentType2 sql=equivalent_types+ field1 Int+#ifdef WITH_POSTGRESQL+ field2 T.Text+ field3 T.Text sqltype=us_postal_code+#endif+ deriving Eq Show+|]++specs :: Spec+specs = describe "doesn't migrate equivalent types" $ do+ it "works" $ asIO $ runResourceT $ runConn $ do++#ifdef WITH_POSTGRESQL+ _ <- rawExecute "DROP DOMAIN IF EXISTS us_postal_code" []+ _ <- rawExecute "CREATE DOMAIN us_postal_code AS TEXT CHECK(VALUE ~ '^\\d{5}$')" []+#endif++#ifndef WITH_NOSQL+ _ <- runMigrationSilent migrateAll1+ xs <- getMigration migrateAll2+ liftIO $ xs @?= []+#else+ return ()+#endif+ ++asIO :: IO a -> IO a+asIO = id
+ src/HtmlTest.hs view
@@ -0,0 +1,58 @@+{-# OPTIONS_GHC -fno-warn-unused-binds #-}+{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}+module HtmlTest (specs) where++import Database.Persist.TH+import Data.Char (generalCategory, GeneralCategory(..))+import qualified Data.Text as T+import System.Random (randomIO, randomRIO, Random)+import Control.Monad.Trans.Resource (runResourceT)++import Init+import Text.Blaze.Html+import Text.Blaze.Html.Renderer.Text++-- Test lower case names+share [mkPersist persistSettings, mkMigrate "htmlMigrate"] [persistLowerCase|+HtmlTable+ html Html+ deriving+|]++cleanDB :: (MonadIO m, PersistQuery backend, PersistEntityBackend HtmlTable ~ backend) => ReaderT backend m ()+cleanDB = do+ deleteWhere ([] :: [Filter HtmlTable])++specs :: Spec+specs = describe "html" $ do+ it "works" $ asIO $ runResourceT $ runConn $ do+#ifndef WITH_NOSQL+ _ <- runMigrationSilent htmlMigrate+ -- Ensure reading the data from the database works...+ _ <- runMigrationSilent htmlMigrate+#endif++ sequence_ $ replicate 1000 $ do+ x <- liftIO randomValue+ key <- insert $ HtmlTable x+ Just (HtmlTable y) <- get key+ liftIO $ do+ renderHtml x @?= renderHtml y++randomValue :: IO Html+randomValue =+ preEscapedToMarkup+ . T.pack+ . filter ((`notElem` forbidden) . generalCategory)+ . filter (<= '\xFFFF') -- only BMP+ . filter (/= '\0') -- no nulls+ <$> randomIOs+ where forbidden = [NotAssigned, PrivateUse]++asIO :: IO a -> IO a+asIO = id++randomIOs :: Random a => IO [a]+randomIOs = do+ len <- randomRIO (0, 20)+ sequence $ replicate len randomIO
+ src/Init.hs view
@@ -0,0 +1,343 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TemplateHaskell #-}+module Init (+ (@/=), (@==), (==@)+ , assertNotEqual+ , assertNotEmpty+ , assertEmpty+ , isTravis+ , BackendMonad+ , runConn++ , MonadIO+ , persistSettings+ , MkPersistSettings (..)+#ifdef WITH_NOSQL+ , dbName+ , db'+ , setup+ , mkPersistSettings+ , Action+ , Context+#else+ , db+ , sqlite_database+ , sqlite_database_file+#endif+ , BackendKey(..)+ , generateKey++ -- re-exports+ , (A.<$>), (A.<*>)+ , module Database.Persist+ , module Test.Hspec+ , module Test.HUnit+ , liftIO+ , mkPersist, mkMigrate, share, sqlSettings, persistLowerCase, persistUpperCase+ , Int32, Int64+ , Text+ , module Control.Monad.Trans.Reader+ , module Control.Monad+#ifndef WITH_NOSQL+ , module Database.Persist.Sql+#else+ , PersistFieldSql(..)+#endif+ , BS.ByteString+ , SomeException+) where++-- re-exports+import Control.Applicative as A ((<$>), (<*>))+import Control.Exception (SomeException)+import Control.Monad (void, replicateM, liftM, when, forM_)+import Control.Monad.Trans.Reader+import Database.Persist.TH (mkPersist, mkMigrate, share, sqlSettings, persistLowerCase, persistUpperCase, MkPersistSettings(..))+import Test.Hspec++-- testing+import Test.HUnit ((@?=),(@=?), Assertion, assertFailure, assertBool)+import Test.QuickCheck++import qualified Data.ByteString as BS+import Data.Text (Text, unpack)+import Database.Persist+import Database.Persist.TH ()+import System.Environment (getEnvironment)++#ifdef WITH_NOSQL+import Database.Persist.Sql (PersistFieldSql(..))+import Database.Persist.TH (mkPersistSettings)+import Language.Haskell.TH.Syntax (Type(..))++# ifdef WITH_MONGODB+import qualified Database.MongoDB as MongoDB+import Database.Persist.MongoDB (Action, withMongoPool, runMongoDBPool, defaultMongoConf, applyDockerEnv, BackendKey(..))+# endif++# ifdef WITH_ZOOKEEPER+import Data.IORef (newIORef, IORef, writeIORef, readIORef)+import qualified Data.Text as T+import Database.Persist.Zookeeper (Action, withZookeeperPool, runZookeeperPool, ZookeeperConf(..), defaultZookeeperConf, BackendKey(..), deleteRecursive)+import qualified Database.Zookeeper as Z+import System.IO.Unsafe (unsafePerformIO)+# endif++#else+import Control.Monad.Logger+import Control.Monad.Trans.Resource (ResourceT, runResourceT)+import Database.Persist.Sql+import System.Log.FastLogger (fromLogStr)++# ifdef WITH_POSTGRESQL+import Data.Maybe (fromMaybe)+import Data.Monoid ((<>))+import Database.Persist.Postgresql+# endif+# ifdef WITH_SQLITE+import Database.Persist.Sqlite+# endif+# ifdef WITH_MYSQL+import Database.Persist.MySQL+import qualified Database.MySQL.Base as MySQL+# endif+import Data.IORef (newIORef, IORef, writeIORef, readIORef)+import System.IO.Unsafe (unsafePerformIO)+#endif++import Control.Monad (unless, (>=>))+import Control.Monad.IO.Unlift (MonadUnliftIO)++-- Data types+import Data.Int (Int32, Int64)++import Control.Monad.IO.Class+++#ifdef WITH_MONGODB+setup :: Action IO ()+setup = setupMongo+type Context = MongoDB.MongoContext+#endif++#ifdef WITH_ZOOKEEPER+setup :: Action IO ()+setup = setupZookeeper+type Context = Z.Zookeeper+#endif+++++(@/=), (@==), (==@) :: (Eq a, Show a, MonadIO m) => a -> a -> m ()+infix 1 @/= --, /=@+actual @/= expected = liftIO $ assertNotEqual "" expected actual++infix 1 @==, ==@+actual @== expected = liftIO $ actual @?= expected+expected ==@ actual = liftIO $ expected @=? actual++{-+expected /=@ actual = liftIO $ assertNotEqual "" expected actual+-}+++assertNotEqual :: (Eq a, Show a) => 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++assertEmpty :: (Monad m, MonadIO m) => [a] -> m ()+assertEmpty xs = liftIO $ assertBool "" (null xs)++assertNotEmpty :: (Monad m, MonadIO m) => [a] -> m ()+assertNotEmpty xs = liftIO $ assertBool "" (not (null xs))++isTravis :: IO Bool+isTravis = do+ env <- liftIO getEnvironment+ return $ case lookup "TRAVIS" env of+ Just "true" -> True+ _ -> False++_debugOn :: Bool+#ifdef DEBUG+_debugOn = True+#else+_debugOn = False+#endif++#ifdef WITH_POSTGRESQL+dockerPg :: IO (Maybe BS.ByteString)+dockerPg = do+ env <- liftIO getEnvironment+ return $ case lookup "POSTGRES_NAME" env of+ Just _name -> Just "postgres" -- /persistent/postgres+ _ -> Nothing+#endif++#ifdef WITH_NOSQL+persistSettings :: MkPersistSettings+persistSettings = (mkPersistSettings $ ConT ''Context) { mpsGeneric = True }++dbName :: Text+dbName = "persistent"++type BackendMonad = Context++#ifdef WITH_MONGODB+runConn :: MonadUnliftIO m => Action m backend -> m ()+runConn f = do+ conf <- liftIO $ applyDockerEnv $ defaultMongoConf dbName -- { mgRsPrimary = Just "replicaset" }+ void $ withMongoPool conf $ runMongoDBPool MongoDB.master f++setupMongo :: Action IO ()+setupMongo = void $ MongoDB.dropDatabase dbName+#endif++#ifdef WITH_ZOOKEEPER+runConn :: MonadUnliftIO m => Action m backend -> m ()+runConn f = do+ let conf = defaultZookeeperConf {zCoord = "localhost:2181/" ++ T.unpack dbName}+ void $ withZookeeperPool conf $ runZookeeperPool f++setupZookeeper :: Action IO ()+setupZookeeper = do+ liftIO $ Z.setDebugLevel Z.ZLogError+ deleteRecursive "/"+#endif++db' :: Action IO () -> Action IO () -> Assertion+db' actions cleanDB = do+ r <- runConn (actions >> cleanDB)+ return r++instance Arbitrary PersistValue where+ arbitrary = PersistObjectId `fmap` BS.pack `fmap` replicateM 12 arbitrary+#else+persistSettings :: MkPersistSettings+persistSettings = sqlSettings { mpsGeneric = True }+type BackendMonad = SqlBackend+# ifdef WITH_SQLITE+sqlite_database_file :: Text+sqlite_database_file = "testdb.sqlite3"+sqlite_database :: SqliteConnectionInfo+sqlite_database = mkSqliteConnectionInfo sqlite_database_file+# else+sqlite_database_file :: Text+sqlite_database_file = error "Sqlite tests disabled"+sqlite_database :: ()+sqlite_database = error "Sqlite tests disabled"+# endif+runConn :: MonadUnliftIO m => SqlPersistT (LoggingT m) t -> m ()+runConn f = do+ travis <- liftIO isTravis+ let debugPrint = not travis && _debugOn+ let printDebug = if debugPrint then print . fromLogStr else void . return+ flip runLoggingT (\_ _ _ s -> printDebug s) $ do+# ifdef WITH_POSTGRESQL+ _ <- if travis+ then withPostgresqlPool "host=localhost port=5432 user=postgres dbname=persistent" 1 $ runSqlPool f+ else do+ host <- fromMaybe "localhost" A.<$> liftIO dockerPg+ withPostgresqlPool ("host=" <> host <> " port=5432 user=postgres dbname=test") 1 $ runSqlPool f+# else+# ifdef WITH_MYSQL+ -- Since version 5.7.5, MySQL adds a mode value `STRICT_TRANS_TABLES`+ -- which can cause an exception in MaxLenTest, depending on the server+ -- configuration. Persistent tests do not need any of the modes which are+ -- set by default, so it is simplest to clear `sql_mode` for the session.+ let baseConnectInfo =+ defaultConnectInfo {+ connectOptions =+ connectOptions defaultConnectInfo+ ++ [MySQL.InitCommand "SET SESSION sql_mode = '';\0"]+ }+ _ <- if not travis+ then withMySQLPool baseConnectInfo+ { connectHost = "localhost"+ , connectUser = "test"+ , connectPassword = "test"+ , connectDatabase = "test"+ } 1 $ runSqlPool f+ else withMySQLPool baseConnectInfo+ { connectHost = "localhost"+ , connectUser = "travis"+ , connectPassword = ""+ , connectDatabase = "persistent"+ } 1 $ runSqlPool f+# else+ _<-withSqlitePoolInfo sqlite_database 1 $ runSqlPool f+# endif+# endif+ return ()++db :: SqlPersistT (LoggingT (ResourceT IO)) () -> Assertion+db actions = do+ runResourceT $ runConn $ actions >> transactionUndo++#if !MIN_VERSION_random(1,0,1)+instance Random Int32 where+ random g =+ let ((i::Int), g') = random g in+ (fromInteger $ toInteger i, g')+ randomR (lo, hi) g =+ let ((i::Int), g') = randomR (fromInteger $ toInteger lo, fromInteger $ toInteger hi) g in+ (fromInteger $ toInteger i, g')++instance Random Int64 where+ random g =+ let ((i0::Int32), g0) = random g+ ((i1::Int32), g1) = random g0 in+ (fromInteger (toInteger i0) + fromInteger (toInteger i1) * 2 ^ (32::Int), g1)+ randomR (lo, hi) g = -- TODO : generate on the whole range, and not only on a part of it+ let ((i::Int), g') = randomR (fromInteger $ toInteger lo, fromInteger $ toInteger hi) g in+ (fromInteger $ toInteger i, g')+#endif++instance Arbitrary PersistValue where+ arbitrary = PersistInt64 `fmap` choose (0, maxBound)++#endif++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++#ifdef WITH_NOSQL+#ifdef WITH_MONGODB+generateKey :: IO (BackendKey Context)+generateKey = MongoKey `liftM` MongoDB.genObjectId+#endif++#ifdef WITH_ZOOKEEPER+keyCounter :: IORef Int64+keyCounter = unsafePerformIO $ newIORef 1+{-# NOINLINE keyCounter #-}++generateKey :: IO (BackendKey Context)+generateKey = do+ i <- readIORef keyCounter+ writeIORef keyCounter (i + 1)+ return $ ZooKey $ T.pack $ show i+#endif++#else+keyCounter :: IORef Int64+keyCounter = unsafePerformIO $ newIORef 1+{-# NOINLINE keyCounter #-}++generateKey :: IO (BackendKey SqlBackend)+generateKey = do+ i <- readIORef keyCounter+ writeIORef keyCounter (i + 1)+ return $ SqlBackendKey $ i+#endif
+ src/InsertDuplicateUpdate.hs view
@@ -0,0 +1,103 @@+{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-orphans -O0 #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module InsertDuplicateUpdate where++import Init+#ifdef WITH_MYSQL+import Database.Persist.MySQL+import Data.List (sort)++share [mkPersist sqlSettings, mkMigrate "duplicateMigrate"] [persistUpperCase|+ Item+ name Text sqltype=varchar(80)+ description Text+ price Double Maybe+ quantity Int Maybe++ Primary name+ deriving Eq Show Ord++|]++specs :: Spec+specs = describe "DuplicateKeyUpdate" $ do+ let item1 = Item "item1" "" (Just 3) Nothing+ item2 = Item "item2" "hello world" Nothing (Just 2)+ items = [item1, item2]+ describe "insertOnDuplicateKeyUpdate" $ do+ it "inserts appropriately" $ db $ do+ deleteWhere ([] :: [Filter Item])+ insertOnDuplicateKeyUpdate item1 [ItemDescription =. "i am item 1"]+ Just item <- get (ItemKey "item1")+ item @== item1++ it "performs only updates given if record already exists" $ db $ do+ deleteWhere ([] :: [Filter Item])+ let newDescription = "I am a new description"+ _ <- insert item1+ insertOnDuplicateKeyUpdate+ (Item "item1" "i am inserted description" (Just 1) (Just 2))+ [ItemDescription =. newDescription]+ Just item <- get (ItemKey "item1")+ item @== item1 { itemDescription = newDescription }++ describe "insertManyOnDuplicateKeyUpdate" $ do+ it "inserts fresh records" $ db $ do+ deleteWhere ([] :: [Filter Item])+ insertMany_ items+ let newItem = Item "item3" "fresh" Nothing Nothing+ insertManyOnDuplicateKeyUpdate+ (newItem : items)+ [copyField ItemDescription]+ []+ dbItems <- map entityVal <$> selectList [] []+ sort dbItems @== sort (newItem : items)+ it "updates existing records" $ db $ do+ deleteWhere ([] :: [Filter Item])+ insertMany_ items+ insertManyOnDuplicateKeyUpdate+ items+ []+ [ItemQuantity +=. Just 1]+ it "only copies passing values" $ db $ do+ deleteWhere ([] :: [Filter Item])+ insertMany_ items+ let newItems = map (\i -> i { itemQuantity = Just 0, itemPrice = fmap (*2) (itemPrice i) }) items+ postUpdate = map (\i -> i { itemPrice = fmap (*2) (itemPrice i) }) items+ insertManyOnDuplicateKeyUpdate+ newItems+ [ copyUnlessEq ItemQuantity (Just 0)+ , copyField ItemPrice+ ]+ []+ dbItems <- sort . fmap entityVal <$> selectList [] []+ dbItems @== sort postUpdate+ it "inserts without modifying existing records if no updates specified" $ db $ do+ let newItem = Item "item3" "hi friends!" Nothing Nothing+ deleteWhere ([] :: [Filter Item])+ insertMany_ items+ insertManyOnDuplicateKeyUpdate+ (newItem : items)+ []+ []+ dbItems <- sort . fmap entityVal <$> selectList [] []+ dbItems @== sort (newItem : items)++#else+specs :: Spec+specs = describe "DuplicateKeyUpdate" $ do+ it "Is only supported on MySQL currently." $ do+ True `shouldBe` True+#endif
+ src/LargeNumberTest.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}+module LargeNumberTest where++import Init+import Data.Word++#ifdef WITH_NOSQL+mkPersist persistSettings [persistUpperCase|+#else+share [mkPersist sqlSettings, mkMigrate "numberMigrate"] [persistLowerCase|+#endif+ Number+ intx Int+ int32 Int32+ word32 Word32+ int64 Int64+ word64 Word64+ deriving Show Eq+|]++#ifdef WITH_NOSQL+cleanDB :: (MonadIO m, PersistQuery backend, PersistEntityBackend Number ~ backend) => ReaderT backend m ()+cleanDB = do+ deleteWhere ([] :: [Filter Number])+db :: Action IO () -> Assertion+db = db' cleanDB+#endif++specs :: Spec+specs = describe "persistent" $ do+ it "large numbers" $ db $ 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++ 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
+ src/MaxLenTest.hs view
@@ -0,0 +1,55 @@+{-# OPTIONS_GHC -fno-warn-unused-binds #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, FlexibleInstances, EmptyDataDecls, MultiParamTypeClasses #-}++module MaxLenTest (+ specs+#ifndef WITH_NOSQL+ , maxlenMigrate+#endif+) where++import Init+import Data.String (IsString)++#ifdef WITH_NOSQL+db :: Action IO () -> Assertion+db = db' (return ())+mkPersist persistSettings [persistUpperCase|+#else+share [mkPersist sqlSettings, mkMigrate "maxlenMigrate"] [persistLowerCase|+#endif+ MaxLen+ text1 Text+ text2 Text maxlen=3+ bs1 ByteString+ bs2 ByteString maxlen=3+ str1 String+ str2 String maxlen=3+ MLText1 text1+ MLText2 text2+ MLBs1 bs1+ MLBs2 bs2+ MLStr1 str1+ MLStr2 str2+ deriving Show Eq+|]++specs :: Spec+specs = describe "Maximum length attribute" $ do+ it "" $ db $ 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'+
+ src/MigrationColumnLengthTest.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module MigrationColumnLengthTest where++import Database.Persist.TH+import qualified Data.Text as T++import Init++#ifdef WITH_NOSQL+mkPersist persistSettings [persistUpperCase|+#else+share [mkPersist sqlSettings, mkMigrate "migration"] [persistLowerCase|+#endif+VaryingLengths+ field1 Int+ field2 T.Text sqltype=varchar(5)+|]+++specs :: Spec+specs = describe "Migration" $ do+#ifdef WITH_NOSQL+ return ()+#else+ it "is idempotent" $ db $ do+ again <- getMigration migration+ liftIO $ again @?= []+#endif+
+ src/MigrationIdempotencyTest.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module MigrationIdempotencyTest where++import Database.Persist.TH+import qualified Data.Text as T++import Init++#ifdef WITH_NOSQL+mkPersist persistSettings [persistUpperCase|+#else+share [mkPersist sqlSettings, mkMigrate "migration"] [persistLowerCase|+#endif+Idempotency+ field1 Int+ field2 T.Text sqltype=varchar(5)+ field3 T.Text sqltype=mediumtext+ field4 T.Text sqltype=longtext+ field5 T.Text sqltype=mediumblob+ field6 T.Text sqltype=longblob+ field7 Double sqltype=double(6,5)+|]+++specs :: Spec+specs = describe "MySQL migration with backend-specific sqltypes" $ do+#ifdef WITH_NOSQL+ return ()+#else+ it "is idempotent" $ db $ do+ again <- getMigration migration+ liftIO $ again @?= []+#endif
+ src/MigrationOnlyTest.hs view
@@ -0,0 +1,54 @@+{-# OPTIONS_GHC -fno-warn-unused-binds #-}+{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module MigrationOnlyTest (specs) where++import Database.Persist.TH+import Control.Monad.Trans.Resource (runResourceT)+import qualified Data.Text as T++import Init++#ifdef WITH_NOSQL+mkPersist persistSettings [persistUpperCase|+#else+share [mkPersist sqlSettings, mkMigrate "migrateAll1"] [persistLowerCase|+#endif+TwoField1 sql=two_field+ field1 Int+ field2 T.Text+ field3 Bool Maybe+ deriving Eq Show+|]++#ifdef WITH_NOSQL+mkPersist persistSettings [persistUpperCase|+#else+share [mkPersist sqlSettings, mkMigrate "migrateAll2", mkDeleteCascade sqlSettings] [persistLowerCase|+#endif+TwoField+ field1 Int+ field2 T.Text+ field3 Bool Maybe MigrationOnly+ deriving Eq Show++Referencing+ field1 Int+ field2 TwoFieldId MigrationOnly+|]++specs :: Spec+specs = describe "migration only" $ do+ it "works" $ asIO $ runResourceT $ runConn $ do+#ifndef WITH_NOSQL+ _ <- runMigrationSilent migrateAll1+ _ <- runMigrationSilent migrateAll2+#endif+ let tf = TwoField 5 "hello"+ tid <- insert tf+ mtf <- get tid+ liftIO $ mtf @?= Just tf+ deleteWhere ([] :: [Filter TwoField])++asIO :: IO a -> IO a+asIO = id
+ src/MigrationTest.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module MigrationTest where++import Database.Persist.TH+import qualified Data.Text as T++import Init++#ifdef WITH_NOSQL+mkPersist persistSettings [persistUpperCase|+#else+share [mkPersist sqlSettings, mkMigrate "migrationMigrate", mkDeleteCascade sqlSettings] [persistLowerCase|+#endif+Target+ field1 Int+ field2 T.Text+ UniqueTarget field1 field2+ deriving Eq Show++Source+ field3 Int+ field4 TargetId+|]++#ifdef WITH_NOSQL+mkPersist persistSettings [persistUpperCase|+#else+share [mkPersist sqlSettings, mkMigrate "migrationAddCol", mkDeleteCascade sqlSettings] [persistLowerCase|+#endif+Target1 sql=target+ field1 Int+ field2 T.Text+ UniqueTarget1 field1 field2+ deriving Eq Show++Source1 sql=source+ field3 Int+ extra Int+ field4 Target1Id+|]++#ifndef WITH_NOSQL+specs :: Spec+specs = describe "Migration" $ do+ it "is idempotent" $ db $ do+ again <- getMigration migrationMigrate+ liftIO $ again @?= []+ it "really is idempotent" $ db $ do+ runMigration migrationMigrate+ again <- getMigration migrationMigrate+ liftIO $ again @?= []+ it "can add an extra column" $ db $ 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.+ _ <- runMigration migrationAddCol+ again <- getMigration migrationAddCol+ liftIO $ again @?= []+#endif
+ src/PersistTestPetCollarType.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TemplateHaskell #-}+module PersistTestPetCollarType where++import GHC.Generics+import Data.Aeson+import Database.Persist.TH+import Data.Text (Text)++data PetCollar = PetCollar {tag :: Text, bell :: Bool}+ deriving (Generic, Eq, Show)+instance ToJSON PetCollar+instance FromJSON PetCollar++derivePersistFieldJSON "PetCollar"
+ src/PersistTestPetType.hs view
@@ -0,0 +1,8 @@+{-# LANGUAGE TemplateHaskell #-}+module PersistTestPetType where++import Database.Persist.TH++data PetType = Cat | Dog+ deriving (Show, Read, Eq)+derivePersistField "PetType"
+ src/PersistUniqueTest.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}+module PersistUniqueTest where++import Init++-- mpsGeneric = False is due to a bug or at least lack of a feature in mkKeyTypeDec TH.hs+#if WITH_NOSQL+mkPersist persistSettings { mpsGeneric = False } [persistUpperCase|+#else+share [mkPersist persistSettings { mpsGeneric = False }, mkMigrate "migration"] [persistLowerCase|+#endif+ Fo+ foo Int+ bar Int+ Primary foo+ UniqueBar bar+ deriving Eq Show+|]+#ifdef WITH_NOSQL+cleanDB :: (MonadIO m, PersistQuery backend, PersistEntityBackend Fo ~ backend) => ReaderT backend m ()+cleanDB = do+ deleteWhere ([] :: [Filter Fo])++db :: Action IO () -> Assertion+db = db' cleanDB+#endif++specs :: Spec+specs = describe "custom primary key" $ do+#ifdef WITH_NOSQL+ return ()+#else+ it "getBy" $ db $ do+ let b = 5+ k <- insert $ Fo 3 b+ Just vk <- get k+ Just vu <- getBy (UniqueBar b)+ vu @== Entity k vk+ it "insertUniqueEntity" $ db $ do+ let fo = Fo 3 5+ Just (Entity _ insertedFoValue) <- insertUniqueEntity fo+ Nothing <- insertUniqueEntity fo+ fo @== insertedFoValue+#endif
+ src/PersistentTest.hs view
@@ -0,0 +1,1208 @@+{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-orphans #-}+{-# LANGUAGE UndecidableInstances #-} -- FIXME+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}+module PersistentTest where++import Test.HUnit hiding (Test)+import Control.Monad.Trans.Resource (runResourceT)+import Test.Hspec.Expectations ()+import Test.Hspec.QuickCheck(prop)+import UnliftIO (MonadUnliftIO, catch)++import Database.Persist++#ifdef WITH_NOSQL+#ifdef WITH_MONGODB+import qualified Database.MongoDB as MongoDB+import Database.Persist.MongoDB (toInsertDoc, docToEntityThrow, collectionName, recordToDocument)+#endif++#else++import Database.Persist.TH (mkDeleteCascade, mkSave)+import qualified Data.Text as T++# ifdef WITH_POSTGRESQL+import Data.List (sort)+# endif+# if WITH_MYSQL+import Database.Persist.MySQL()+# endif++#endif++import Control.Monad.IO.Class++import Web.PathPieces (PathPiece (..))+import Data.Maybe (fromJust)+import qualified Data.HashMap.Lazy as M+import Init+import Data.Aeson++import Data.Conduit+import qualified Data.Conduit.List as CL+import Data.Function (on)+import Data.Functor.Identity+import Data.Functor.Constant+import PersistTestPetType+import PersistTestPetCollarType++#ifdef WITH_NOSQL+mkPersist persistSettings [persistUpperCase|+#else+share [mkPersist persistSettings, mkMigrate "testMigrate", mkDeleteCascade persistSettings, mkSave "_ignoredSave"] [persistUpperCase|+#endif++-- Dedented comment+ -- Header-level comment+ -- Indented comment+ Person json+ name Text+ age Int "some ignored -- \" attribute"+ color Text Maybe -- this is a comment sql=foobarbaz+ PersonNameKey name -- this is a comment sql=foobarbaz+ deriving Show Eq+ Person1+-- Dedented comment+ -- Header-level comment+ -- Indented comment+ name Text+ age Int+ PersonMaybeAge+ name Text+ age Int Maybe+ PersonMay json+ name Text Maybe+ color Text Maybe+ deriving Show Eq+ Pet+ ownerId PersonId+ name Text+ -- deriving Show Eq+-- Dedented comment+ -- Header-level comment+ -- Indented comment+ type PetType+ MaybeOwnedPet+ ownerId PersonId Maybe+ name Text+ type PetType+-- Dedented comment+ -- Header-level comment+ -- Indented comment+ NeedsPet+ petKey PetId+ OutdoorPet+ ownerId PersonId+ collar PetCollar+ type PetType++ -- From the scaffold+ UserPT+ ident Text+ password Text Maybe+ UniqueUserPT ident+ EmailPT+ email Text+ user UserPTId Maybe+ verkey Text Maybe+ UniqueEmailPT email++ Upsert+ email Text+ attr Text+ extra Text+ age Int + UniqueUpsert email+ deriving Eq Show++ UpsertBy+ email Text+ city Text+ attr Text+ UniqueUpsertBy email+ UniqueUpsertByCity city+ deriving Eq Show++ Strict+ !yes Int+ ~no Int+ def Int+|]++deriving instance Show (BackendKey backend) => Show (PetGeneric backend)+deriving instance Eq (BackendKey backend) => Eq (PetGeneric backend)++share [mkPersist persistSettings { mpsPrefixFields = False, mpsGeneric = False }+#ifdef WITH_NOSQL+ ] [persistUpperCase|+#else+ , mkMigrate "noPrefixMigrate"+ ] [persistLowerCase|+#endif+NoPrefix1+ someFieldName Int+ deriving Show Eq+NoPrefix2+ someOtherFieldName Int+ unprefixedRef NoPrefix1Id+ deriving Show Eq++NoPrefixSum+ unprefixedLeft Int+ unprefixedRight String+ deriving Show Eq+|]++cleanDB :: (MonadIO m, PersistQuery backend, PersistEntityBackend EmailPT ~ backend) => ReaderT backend m ()+cleanDB = do+ deleteWhere ([] :: [Filter Person])+ deleteWhere ([] :: [Filter Person1])+ deleteWhere ([] :: [Filter Pet])+ deleteWhere ([] :: [Filter MaybeOwnedPet])+ deleteWhere ([] :: [Filter NeedsPet])+ deleteWhere ([] :: [Filter OutdoorPet])+ deleteWhere ([] :: [Filter UserPT])+ deleteWhere ([] :: [Filter EmailPT])++#ifdef WITH_NOSQL+db :: Action IO () -> Assertion+db = db' cleanDB+#endif++catchPersistException :: MonadUnliftIO m => m a -> b -> m b+catchPersistException action errValue = do+ Left res <-+ (Right `fmap` action) `catch`+ (\(_::PersistException) -> return $ Left errValue)+ return res+++specs :: Spec+specs = describe "persistent" $ do+ 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 "FilterOr []" $ db $ do+ let p = Person "z" 1 Nothing+ _ <- insert p+#ifdef WITH_MONGODB+ ps <- catchPersistException (selectList [FilterOr []] [Desc PersonAge]) []+#else+ ps <- (selectList [FilterOr []] [Desc PersonAge])+#endif+ assertEmpty ps++ it "||. []" $ db $ do+ let p = Person "z" 1 Nothing+ _ <- insert p+#ifdef WITH_MONGODB+ c <- catchPersistException (count $ [PersonName ==. "a"] ||. []) 1+#else+ c <- (count $ [PersonName ==. "a"] ||. [])+#endif+ c @== (1::Int)++ it "FilterAnd []" $ db $ do+ let p = Person "z" 1 Nothing+ _ <- insert p+ ps <- selectList [FilterAnd []] [Desc PersonAge]+ assertNotEmpty ps++ it "order of opts is irrelevant" $ db $ 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 <- fmap (map $ personName . entityVal) $ selectList [] [Desc PersonAge, Asc PersonName, OffsetBy 2, LimitTo 3]+ a @== ["y", "v", "x"]++ b <- fmap (map $ personName . entityVal) $ selectList [] [OffsetBy 2, Desc PersonAge, LimitTo 3, Asc PersonName]+ b @== a++ c <- fmap (map $ personName . entityVal) $ selectList [] [OffsetBy 2, Desc PersonAge, LimitTo 3, Asc PersonName, LimitTo 1, OffsetBy 1]+ c @== a+++ it "passes the general tests" $ db $ 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++#ifdef WITH_NOSQL+ updateWhere [PersonName ==. "Michael"] [PersonAge =. 29]+#else+ uc <- updateWhereCount [PersonName ==. "Michael"] [PersonAge =. 29]+ uc @== 1+#endif+ Just mic29 <- get micK+ personAge mic29 @== 29++ 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 ()+#ifdef WITH_ZOOKEEPER+ -- zookeeper backend does not support idfield+ -- zookeeper's key is node-name.+ -- When uniq-key exists, zookeeper's key becomes encoded uniq-key.+#else+ it "persistIdField" $ db $ 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+#endif++ it "!=." $ db $ do+ deleteWhere ([] :: [Filter Person])+ 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" $ db $ do+ deleteWhere ([] :: [Filter PersonMay])+ 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" $ db $ do+ deleteWhere ([] :: [Filter Person1])+ 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" $ db $ 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" $ db $ 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" $ db $ 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++#ifdef WITH_ZOOKEEPER+ it "toPathPiece . fromPathPiece" $ do+ -- Below quickcheck causes error of "Cannot convert PersistObjectId to Text."+ -- Currently, ZooKey does not support PersistObjectId.+ let key1 = ZooKey "hogehogekey" :: (BackendKey BackendMonad)+ key2 = fromJust $ fromPathPiece $ toPathPiece key1 :: (BackendKey BackendMonad)+ toPathPiece key1 `shouldBe` toPathPiece key2+#else+ prop "toPathPiece . fromPathPiece" $ \piece ->+ let key1 = piece :: (BackendKey BackendMonad)+ key2 = fromJust $ fromPathPiece $ toPathPiece key1 :: (BackendKey BackendMonad)+ in toPathPiece key1 == toPathPiece key2+#endif++ it "replace" $ db $ 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" $ db $ 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" $ db $ 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 "upsert" $ do+ it "adds a new row with no updates" $ db $ do+ Entity _ u <- upsert (Upsert "a" "new" "" 2) [UpsertAttr =. "update"]+ c <- count ([] :: [Filter Upsert])+ c @== 1+ upsertAttr u @== "new"+ it "keeps the existing row" $ db $ do+#ifdef WITH_MONGODB+ initial <- insertEntity (Upsert "foo" "initial" "" 2)+ update' <- upsert (Upsert "foo" "update" "" 3) []+ update' @== initial +#else+ initial <- insertEntity (Upsert "a" "initial" "" 1)+ update' <- upsert (Upsert "a" "update" "" 2) []+ update' @== initial+#endif + it "updates an existing row - assignment" $ db $ 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"]+ ((==@) `on` entityKey) initial update'+ upsertAttr (entityVal update') @== "update"+ upsertExtra (entityVal update') @== "extra"+#endif+ it "updates existing row - addition " $ db $ 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]+ ((==@) `on` entityKey) initial update'+ upsertAge (entityVal update') @== 5+ upsertExtra (entityVal update') @== "extra"+#endif++ describe "upsertBy" $ do+ let uniqueEmail = UniqueUpsertBy "a"+ uniqueCity = UniqueUpsertByCity "Boston"+ it "adds a new row with no updates" $ db $ do+ Entity _ u <-+ upsertBy+ uniqueEmail+ (UpsertBy "a" "Boston" "new")+ [UpsertByAttr =. "update"]+ c <- count ([] :: [Filter UpsertBy])+ c @== 1+ upsertByAttr u @== "new"+ it "keeps the existing row" $ db $ do+#ifdef WITH_MONGODB+ initial <- insertEntity (UpsertBy "foo" "Chennai" "initial")+ update' <- upsertBy (UniqueUpsertBy "foo") (UpsertBy "foo" "Chennai" "update") []+ update' @== initial+#else+ initial <- insertEntity (UpsertBy "a" "Boston" "initial")+ update' <- upsertBy uniqueEmail (UpsertBy "a" "Boston" "update") []+ update' @== initial+#endif+ it "updates an existing row" $ db $ 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"]+ ((==@) `on` entityKey) initial update'+ upsertByAttr (entityVal update') @== "update"+ upsertByCity (entityVal update') @== "Boston"+#endif+ it "updates by the appropriate constraint" $ db $ 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"]+ ((==@) `on` entityKey) initBoston updBoston+ ((==@) `on` entityKey) initKrum updKrum+ entityVal updBoston @== UpsertBy "bos" "Boston" "bos update"+ entityVal updKrum @== UpsertBy "krum" "Krum" "krum update"++ it "maybe update" $ db $ do+ let noAge = PersonMaybeAge "Michael" Nothing+ keyNoAge <- insert noAge+ noAge2 <- updateGet keyNoAge [PersonMaybeAgeAge +=. Just 2]+ -- the correct answer is very debatable+#ifdef WITH_NOSQL+ personMaybeAgeAge noAge2 @== Just 2+#else+ personMaybeAgeAge noAge2 @== Nothing+#endif++++ it "updateWhere" $ db $ 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" $ db $ 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" $ db $ 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 <- runResourceT $ selectSource [] [Desc PersonAge] $$ await+ ps1 @== Just (Entity k3 p3)++ ps2 <- runResourceT $ selectSource [PersonAge <. 3] [Asc PersonAge] $$ CL.consume+ ps2 @== [Entity k1 p1, Entity k2 p2]++ runResourceT $ 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" $ db $ 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" $ db $ 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 <- runResourceT $ selectKeys [] [Desc PersonAge] $$ await+ ps1 @== Just k3++ ps2 <- runResourceT $ selectKeys [PersonAge <. 3] [Asc PersonAge] $$ CL.consume+ ps2 @== [k1, k2]++ runResourceT $ 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" $ db $ do+ _ <- insertMany_ ([] :: [Person])+ rows <- count ([] :: [Filter Person])+ rows @== 0+ _ <- insertMany ([] :: [Person])+ rows2 <- count ([] :: [Filter Person])+ rows2 @== 0+ _ <- insertEntityMany ([] :: [Entity Person])+ rows3 <- count ([] :: [Filter Person])+ rows3 @== 0++ it "insertEntityMany" $ db $ 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 Person])+ rows @== 5++ it "insertBy" $ db $ do+ Right _ <- insertBy $ Person "name" 1 Nothing+ Left _ <- insertBy $ Person "name" 1 Nothing+ Right _ <- insertBy $ Person "name2" 1 Nothing+ return ()++ it "insertKey" $ db $ do+ k <- liftIO (PersonKey `fmap` generateKey)+ insertKey k $ Person "Key" 26 Nothing+ Just (Entity k2 _) <- selectFirst [PersonName ==. "Key"] []+ k2 @== k++ it "insertEntity" $ db $ do+ Entity k p <- insertEntity $ Person "name" 1 Nothing+ Just p2 <- get k+ p2 @== p++ it "insertRecord" $ db $ do+ let record = Person "name" 1 Nothing+ record' <- insertRecord record + record' @== record++ it "getEntity" $ db $ do+ Entity k p <- insertEntity $ Person "name" 1 Nothing+ Just (Entity k2 p2) <- getEntity k+ p @== p2+ k @== k2++ it "getJustEntity" $ db $ do+ let p1 = Person "name" 1 Nothing+ k1 <- insert p1+ Entity k2 p2 <- getJustEntity k1+ p1 @== p2+ k1 @== k2++ it "repsert" $ db $ 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" $ db $ 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" $ db $ 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" $ db $ 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" $ db $ 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++#ifdef WITH_ZOOKEEPER+ -- zookeeper backend does not support idfield+ -- zookeeper's key is node-name.+ -- When uniq-key exists, zookeeper's key becomes encoded uniq-key.+#else+ it "idIn" $ db $ 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]+#endif++ it "In" $ db $ 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" $ db $ do+ let p = Person "D" 0 Nothing+ k <- insert p+ liftIO $ toJSON (Entity k p) @?=+ Object (M.fromList [("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"+ -}+++#ifdef WITH_NOSQL+#ifdef WITH_MONGODB+ describe "raw MongoDB helpers" $ do+ it "collectionName" $ do+ collectionName (Person "Duder" 0 Nothing) @?= "Person"++ it "toInsertFields, entityFields, & docToEntityThrow" $ db $ do+ let p1 = Person "Duder" 0 Nothing+ let doc = toInsertDoc p1+ MongoDB.ObjId _id <- MongoDB.insert "Person" $ doc+ let idSelector = "_id" MongoDB.=: _id+ Entity _ ent1 <- docToEntityThrow $ idSelector:doc+ liftIO $ p1 @?= ent1++ let p2 = p1 {personColor = Just "blue"}+ let doc2 = idSelector:recordToDocument p2+ MongoDB.save "Person" doc2+ Entity _ ent2 <- docToEntityThrow doc2+ liftIO $ p2 @?= ent2+#endif+#else+ it "rawSql/2+2" $ db $ do+ ret <- rawSql "SELECT 2+2" []+ liftIO $ ret @?= [Single (4::Int)]++ it "sqlQQ/?-?" $ db $ do+ ret <- [sqlQQ| SELECT #{2 :: Int}+#{2 :: Int} |]+ liftIO $ ret @?= [Single (4::Int)]++ it "rawSql/?-?" $ db $ do+ ret <- rawSql "SELECT ?-?" [PersistInt64 5, PersistInt64 3]+ liftIO $ ret @?= [Single (2::Int)]++ it "sqlQQ/?-?" $ db $ do+ ret <- [sqlQQ| SELECT #{5 :: Int}-#{3 :: Int} |]+ liftIO $ ret @?= [Single (2::Int)]++ it "rawSql/NULL" $ db $ do+ ret <- rawSql "SELECT NULL" []+ liftIO $ ret @?= [Nothing :: Maybe (Single Int)]++ it "sqlQQ/NULL" $ db $ do+ ret <- [sqlQQ| SELECT NULL |]+ liftIO $ ret @?= [Nothing :: Maybe (Single Int)]++ it "rawSql/entity" $ db $ do+ let insert' :: (PersistStore backend, PersistEntity val, PersistEntityBackend val ~ BaseBackend backend, MonadIO m)+ => 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+ (p3k, _ ) <- insert' $ Person "Cassandra" 19 Nothing+ (_ , _ ) <- insert' $ Person "Thiago" 19 Nothing+ (a1k, a1) <- insert' $ Pet p1k "Rodolfo" Cat+ (a2k, a2) <- insert' $ Pet p1k "Zeno" Cat+ (a3k, a3) <- insert' $ Pet p2k "Lhama" Dog+ (_ , _ ) <- insert' $ Pet p3k "Abacate" Cat+ escape <- ((. DBName) . connEscapeName) `fmap` ask+ person <- getTableName (error "rawSql Person" :: Person)+ name <- getFieldName PersonName+ 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+ ]+ 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) ]+ 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)) ]+ 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) ]++ it "rawSql/order-proof" $ db $ do+ let p1 = Person "Zacarias" 93 Nothing+ p1k <- insert p1+ escape <- ((. DBName) . connEscapeName) `fmap` ask+ let query = T.concat [ "SELECT ?? "+ , "FROM ", escape "Person"+ ]+ ret1 <- rawSql query []+ ret2 <- rawSql query [] :: MonadIO m => SqlPersistT m [Entity (ReverseFieldOrder Person)]+ liftIO $ ret1 @?= [Entity p1k p1]+ liftIO $ ret2 @?= [Entity (RFOKey $ unPersonKey $ p1k) (RFO p1)]++ it "rawSql/OUTER JOIN" $ db $ do+ let insert' :: (PersistStore backend, PersistEntity val, PersistEntityBackend val ~ BaseBackend backend, MonadIO m)+ => 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+ (a1k, a1) <- insert' $ Pet p1k "Rodolfo" Cat+ (a2k, a2) <- insert' $ Pet p1k "Zeno" Cat+ escape <- ((. DBName) . connEscapeName) `fmap` ask+ let query = T.concat [ "SELECT ??, ?? "+ , "FROM ", person+ , "LEFT OUTER JOIN ", pet+ , " ON ", person, ".", escape "id"+ , " = ", pet, ".", escape "ownerId"+ , " ORDER BY ", person, ".", escape "name"]+ person = escape "Person"+ 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) ]++ it "sqlQQ/entity" $ db $ do+ let insert'+ :: PersistStore backend+ => PersistEntity val+ => PersistEntityBackend val ~ BaseBackend backend+ => MonadIO m+ => 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+ (p3k, _ ) <- insert' $ Person "Cassandra" 19 Nothing+ (_ , _ ) <- insert' $ Person "Thiago" 19 Nothing+ (a1k, a1) <- insert' $ Pet p1k "Rodolfo" Cat+ (a2k, a2) <- insert' $ Pet p1k "Zeno" Cat+ (a3k, a3) <- insert' $ Pet p2k "Lhama" Dog+ (_ , _ ) <- insert' $ Pet p3k "Abacate" Cat++ let runQuery+ :: (RawSql a, Functor m, MonadIO m)+ => Int+ -> ReaderT SqlBackend m [a]+ runQuery age =+ [sqlQQ|+ SELECT ??, ??+ FROM+ ^{Person},+ ^{Pet}+ WHERE ^{Person}.@{PersonAge} >= #{age}+ AND ^{Pet}.@{PetOwnerId} = ^{Person}.@{PersonId}+ ORDER BY ^{Person}.@{PersonName}+ |]++ ret <- runQuery 20+ liftIO $ ret @?= [ (Entity p1k p1, Entity a1k a1)+ , (Entity p1k p1, Entity a2k a2)+ , (Entity p2k p2, Entity a3k a3) ]+ ret2 <- runQuery 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)) ]+ ret3 <- runQuery 20+ liftIO $ ret3 @?= [ Just (Entity p1k p1, Entity a1k a1)+ , Just (Entity p1k p1, Entity a2k a2)+ , Just (Entity p2k p2, Entity a3k a3) ]++ it "sqlQQ/order-proof" $ db $ do+ let p1 = Person "Zacarias" 93 Nothing+ p1k <- insert p1++ let runQuery+ :: (RawSql a, Functor m, MonadIO m)+ => ReaderT SqlBackend m [a]+ runQuery = [sqlQQ| SELECT ?? FROM ^{Person} |]+ ret1 <- runQuery+ ret2 <- runQuery :: (MonadIO m, Functor m) => SqlPersistT m [Entity (ReverseFieldOrder Person)]+ liftIO $ ret1 @?= [Entity p1k p1]+ liftIO $ ret2 @?= [Entity (RFOKey $ unPersonKey $ p1k) (RFO p1)]++ it "sqlQQ/OUTER JOIN" $ db $ do+ let insert' :: (PersistStore backend, PersistEntity val, PersistEntityBackend val ~ BaseBackend backend, MonadIO m)+ => 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+ (a1k, a1) <- insert' $ Pet p1k "Rodolfo" Cat+ (a2k, a2) <- insert' $ Pet p1k "Zeno" Cat+ ret <- [sqlQQ|+ SELECT ??, ??+ FROM ^{Person}+ LEFT OUTER JOIN ^{Pet}+ ON ^{Person}.@{PersonId} = ^{Pet}.@{PetOwnerId}+ ORDER BY ^{Person}.@{PersonName}+ |]+ liftIO $ ret @?= [ (Entity p1k p1, Just (Entity a1k a1))+ , (Entity p1k p1, Just (Entity a2k a2))+ , (Entity p2k p2, Nothing) ]++ it "commit/rollback" (caseCommitRollback >> runResourceT (runConn cleanDB))++#ifndef WITH_MYSQL+# ifndef WITH_POSTGRESQL+# ifndef WITH_NOSQL+ it "afterException" $ db $ do+ let catcher :: Monad m => SomeException -> m ()+ catcher _ = return ()+ _ <- insert $ Person "A" 0 Nothing+ _ <- (insert (Person "A" 1 Nothing) >> return ()) `catch` catcher+ _ <- insert $ Person "B" 0 Nothing+ return ()+# endif+# endif+#endif+++#ifndef WITH_NOSQL+ it "mpsNoPrefix" $ db $ 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++ insert_ $ UnprefixedLeftSum 5+ insert_ $ UnprefixedRightSum "Hello"++ it "IsSqlKey instance" $ db $ 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+#endif++ 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++#ifdef WITH_POSTGRESQL+ describe "rawSql/array_agg" $ do+ let runArrayAggTest dbField expected = db $ do+ void $ insertMany+ [ UserPT "a" $ Just "b"+ , UserPT "c" $ Just "d"+ , UserPT "e" Nothing+ , UserPT "g" $ Just "h" ]+ escape <- ((. DBName) . connEscapeName) `fmap` ask+ let query = T.concat [ "SELECT array_agg(", escape dbField, ") "+ , "FROM ", escape "UserPT"+ ]+ [Single xs] <- rawSql query []+ liftIO $ sort xs @?= expected++ it "works for [Text]" $ runArrayAggTest "ident" ["a", "c", "e", "g" :: Text]+ it "works for [Maybe Text]" $ runArrayAggTest "password" [Nothing, Just "b", Just "d", Just "h" :: Maybe Text]+#endif++-- | Reverses the order of the fields of an entity. Used to test+-- @??@ placeholders of 'rawSql'.+newtype ReverseFieldOrder a = RFO {unRFO :: a} deriving (Eq, Show)+instance ToJSON (Key (ReverseFieldOrder a)) where toJSON = error "ReverseFieldOrder"+instance FromJSON (Key (ReverseFieldOrder a)) where parseJSON = error "ReverseFieldOrder"+instance (PersistEntity a) => PersistEntity (ReverseFieldOrder a) where+ type PersistEntityBackend (ReverseFieldOrder a) = PersistEntityBackend a++ newtype Key (ReverseFieldOrder a) = RFOKey { unRFOKey :: BackendKey SqlBackend } deriving (Show, Read, Eq, Ord, PersistField, PersistFieldSql)+ keyFromValues = fmap RFOKey . fromPersistValue . head+ keyToValues = (:[]) . toPersistValue . unRFOKey++ entityDef = revFields . entityDef . liftM unRFO+ where+ revFields ed = ed { entityFields = reverse (entityFields ed) }++ toPersistFields = reverse . toPersistFields . unRFO+ newtype EntityField (ReverseFieldOrder a) b = EFRFO {unEFRFO :: EntityField a b}+ persistFieldDef = persistFieldDef . unEFRFO+ fromPersistValues = fmap RFO . fromPersistValues . reverse++ newtype Unique (ReverseFieldOrder a) = URFO {unURFO :: Unique a }+ persistUniqueToFieldNames = reverse . persistUniqueToFieldNames . unURFO+ persistUniqueToValues = reverse . persistUniqueToValues . unURFO+ persistUniqueKeys = map URFO . reverse . persistUniqueKeys . unRFO++ persistIdField = error "ReverseFieldOrder.persistIdField"+ fieldLens = error "ReverseFieldOrder.fieldLens"++caseCommitRollback :: Assertion+caseCommitRollback = db $ do+ let filt :: [Filter Person1]+ filt = []++ let p = Person1 "foo" 0++ _ <- insert p+ _ <- insert p+ _ <- insert p++ c1 <- count filt+ c1 @== 3++ transactionSave+ c2 <- count filt+ c2 @== 3++ _ <- insert p+ transactionUndo+ c3 <- count filt+ c3 @== 3++ _ <- insert p+ transactionSave+ _ <- insert p+ _ <- insert p+ transactionUndo+ c4 <- count filt+ c4 @== 4++#endif++-- Test proper polymorphism+_polymorphic :: (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)
+ src/PrimaryTest.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}+module PrimaryTest where++import Init++-- mpsGeneric = False is due to a bug or at least lack of a feature in mkKeyTypeDec TH.hs+#if WITH_NOSQL+mkPersist persistSettings { mpsGeneric = False } [persistUpperCase|+#else+share [mkPersist persistSettings { mpsGeneric = False }, mkMigrate "migration"] [persistLowerCase|+#endif+ Foo+ name String+ Primary name+ Bar+ quux FooId++ Trees sql=trees+ name String+ parent String Maybe+ Primary name+ Foreign Trees fkparent parent+|]+#ifdef WITH_NOSQL+cleanDB :: (MonadIO m, PersistQuery backend, PersistEntityBackend Foo ~ backend) => ReaderT backend m ()+cleanDB = do+ deleteWhere ([] :: [Filter Foo])+ deleteWhere ([] :: [Filter Bar])++db :: Action IO () -> Assertion+db = db' cleanDB+#endif++specs :: Spec+specs = describe "primary key reference" $ do+#ifdef WITH_NOSQL+ return ()+#else+# ifdef WITH_MYSQL+ return ()+# else+ it "insert a primary reference" $ db $ do+ kf <- insert $ Foo "name"+ _kb <- insert $ Bar kf+ return ()+ it "uses RawSql for a Primary key" $ db $ do+ key <- insert $ Foo "name"+ keyFromRaw <- rawSql "SELECT name FROM foo LIMIT 1" []+ [key] @== keyFromRaw+# endif+#endif
+ src/Recursive.hs view
@@ -0,0 +1,42 @@+{-# OPTIONS_GHC -fno-warn-unused-binds #-}+{-# LANGUAGE CPP, ScopedTypeVariables, FlexibleInstances #-}+{-# LANGUAGE QuasiQuotes, TypeFamilies, GeneralizedNewtypeDeriving, TemplateHaskell,+ OverloadedStrings, GADTs, FlexibleContexts, EmptyDataDecls, MultiParamTypeClasses #-}+module Recursive (specs,+#ifndef WITH_NOSQL+recursiveMigrate+#endif+) where++import Init++#if WITH_NOSQL+mkPersist persistSettings [persistUpperCase|+#else+share [mkPersist sqlSettings, mkMigrate "recursiveMigrate"] [persistLowerCase|+#endif+SubType+ object [MenuObject]+ deriving Show Eq+MenuObject+ sub SubType Maybe+ deriving Show Eq+|]+#if WITH_NOSQL+cleanDB :: ReaderT Context IO ()+cleanDB = do+ deleteWhere ([] :: [Filter MenuObject])+ deleteWhere ([] :: [Filter SubType])+db :: Action IO () -> Assertion+db = db' cleanDB+#endif++specs :: Spec+specs = describe "recursive definitions" $ do+ it "mutually recursive" $ db $ 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
+ src/RenameTest.hs view
@@ -0,0 +1,108 @@+{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-orphans #-}+{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}+module RenameTest where++#ifndef WITH_NOSQL+import qualified Data.Conduit as C+import qualified Data.Conduit.List as CL+import Control.Monad.Trans.Resource (runResourceT)+#endif+import Data.Time (getCurrentTime, Day, UTCTime(..))+import qualified Data.Map as Map+import qualified Data.Text as T+import Init++-- persistent used to not allow types with an "Id" suffix+-- this verifies that the issue is fixed+type TextId = Text++-- Test lower case names+#if WITH_NOSQL+mkPersist persistSettings [persistUpperCase|+#else+share [mkPersist sqlSettings, mkMigrate "migration"] [persistLowerCase|+#endif+-- This just tests that a field can be named "key"+KeyTable+ key Text+ deriving Eq Show++IdTable+ Id Day default=CURRENT_DATE+ name Text+ -- This was added to test the ability to break a cycle+ -- getting rid of the Maybe should be a compilation failure+ keyTableEmbed IdTable Maybe+ deriving Eq Show++LowerCaseTable+ Id sql=my_id+ fullName Text+ ExtraBlock+ foo bar+ baz+ bin+ ExtraBlock2+ something++RefTable+ someVal Int sql=something_else+ lct LowerCaseTableId+ text TextId+ UniqueRefTable someVal++-- Test a reference to a non-int Id+ForeignIdTable+ idId IdTableId+|]+#if WITH_NOSQL+cleanDB :: ReaderT Context IO ()+cleanDB = do+ deleteWhere ([] :: [Filter IdTable])+ deleteWhere ([] :: [Filter LowerCaseTable])+ deleteWhere ([] :: [Filter RefTable])+db :: Action IO () -> Assertion+db = db' cleanDB+#endif++specs :: Spec+specs = describe "rename specs" $ do+#ifndef WITH_NOSQL+ it "handles lower casing" $ asIO $+ runConn $ do+ runResourceT $ rawQuery "SELECT full_name from lower_case_table WHERE my_id=5" [] C.$$ CL.sinkNull+ runResourceT $ rawQuery "SELECT something_else from ref_table WHERE id=4" [] C.$$ CL.sinkNull+#endif++ it "user specified id, insertKey, no default=" $ db $ do+ let rec2 = IdTable "Foo2" Nothing+ let rec1 = IdTable "Foo1" $ Just rec2+ let rec = IdTable "Foo" $ Just rec1+ now <- liftIO getCurrentTime+ let key = IdTableKey $ utctDay now+ insertKey key rec+ Just rec' <- get key+ rec' @== rec+ (Entity key' _):_ <- selectList ([] :: [Filter IdTable]) []+ key' @== key++#ifndef WITH_MYSQL+# ifndef WITH_NOSQL+ -- this uses default=+ it "user specified id, default=" $ db $ do+ let rec = IdTable "Foo" Nothing+ k <- insert rec+ Just rec' <- get k+ rec' @== rec+# endif+#endif++ it "extra blocks" $+ entityExtra (entityDef (Nothing :: Maybe LowerCaseTable)) @?=+ Map.fromList+ [ ("ExtraBlock", map T.words ["foo bar", "baz", "bin"])+ , ("ExtraBlock2", map T.words ["something"])+ ]++asIO :: IO a -> IO a+asIO = id
+ src/SumTypeTest.hs view
@@ -0,0 +1,58 @@+{-# OPTIONS_GHC -fno-warn-unused-binds #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}+module SumTypeTest (specs) where++import Database.Persist.TH+import Control.Monad.Trans.Resource (runResourceT)+import qualified Data.Text as T++import Init++#if WITH_NOSQL+mkPersist persistSettings [persistLowerCase|+#else+share [mkPersist persistSettings, mkMigrate "sumTypeMigrate"] [persistLowerCase|+#endif+Bicycle+ brand T.Text+Car+ make T.Text+ model T.Text++Vehicle+ bicycle BicycleId+ car CarId+|]++-- 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)++specs :: Spec+specs = describe "sum types" $+ it "works" $ asIO $ runResourceT $ runConn $ do+#ifndef WITH_NOSQL+ _ <- runMigrationSilent sumTypeMigrate+#endif+ 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++ x1 <- get vc1+ liftIO $ x1 @?= Just (VehicleCarSum car1)++ x2 <- get vc2+ liftIO $ x2 @?= Just (VehicleCarSum car2)++ x3 <- get vb1+ liftIO $ x3 @?= Just (VehicleBicycleSum bike1)++asIO :: IO a -> IO a+asIO = id
+ src/UniqueTest.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}+module UniqueTest where++import Init++#ifdef WITH_NOSQL+mkPersist persistSettings [persistUpperCase|+#else+share [mkPersist sqlSettings, mkMigrate "uniqueMigrate"] [persistLowerCase|+#endif+ TestNonNull+ fieldA Int+ UniqueTestNonNull fieldA+ deriving Eq Show+ TestNull+ fieldA Int+ fieldB Int Maybe+ UniqueTestNull fieldA fieldB !force+ deriving Eq Show+#ifndef WITH_NOSQL+ TestCheckmark+ name Text+ value Text+ active Checkmark nullable+ UniqueTestCheckmark name active !force+ deriving Eq Show+#endif+|]+#ifdef WITH_NOSQL+cleanDB :: (MonadIO m, PersistQuery backend, PersistEntityBackend TestNonNull ~ backend) => ReaderT backend m ()+cleanDB = do+ deleteWhere ([] :: [Filter TestNonNull])+ deleteWhere ([] :: [Filter TestNull])++db :: Action IO () -> Assertion+db = db' cleanDB+#endif++specs :: Spec+specs = describe "uniqueness constraints" $+#ifdef WITH_NOSQL+ return ()+#else+ do+ it "are respected for non-nullable Ints" $ do+ let ins = insert . TestNonNull+ (db $ void $ ins 1 >> ins 2)+ (db $ void $ ins 1 >> ins 2 >> ins 1) `shouldThrow` anyException+ (db $ 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)+ (db $ void ctx)+ (db $ void $ ctx >> ins 1 (Just 3)) `shouldThrow` anyException+ (db $ void $ ctx >> ins 1 (Just 4)) `shouldThrow` anyException+ (db $ 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+ (db $ void ctx)+ (db $ void $ ctx >> ins "name" "Melissa" Active) `shouldThrow` anyException+ (db $ void $ ctx >> ins "name" "Melissa" Inactive)+ (db $ void $ ctx >>= flip update [TestCheckmarkActive =. Active])+ (db $ void $ do+ void ctx+ updateWhere [TestCheckmarkName ==. "name"]+ [TestCheckmarkActive =. Inactive]+ ins "name" "Melissa" Active)+#endif
+ test/main.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}++import qualified CompositeTest+import qualified CustomPersistFieldTest+import qualified CustomPrimaryKeyReferenceTest+import qualified DataTypeTest+import qualified EmbedOrderTest+import qualified EmbedTest+import qualified EmptyEntityTest+import qualified HtmlTest+import Init+import qualified LargeNumberTest+import qualified MaxLenTest+import qualified MigrationOnlyTest+import qualified PersistentTest+import qualified PersistUniqueTest+import qualified PrimaryTest+import qualified Recursive+import qualified RenameTest+import qualified SumTypeTest+import qualified InsertDuplicateUpdate+import qualified UniqueTest+import qualified MigrationColumnLengthTest+import qualified EquivalentTypeTest++#ifndef WITH_NOSQL+# ifdef WITH_SQLITE+import Control.Exception (handle, IOException)+import Filesystem (removeFile)+import Filesystem.Path.CurrentOS (fromText)+import qualified MigrationTest+# endif+#endif++#ifdef WITH_MYSQL+import qualified MigrationIdempotencyTest+#endif+++#ifdef WITH_NOSQL+#else++setup :: MonadIO m => Migration -> ReaderT SqlBackend m ()+setup migration = do+ printMigration migration+ runMigrationUnsafe migration+#endif++main :: IO ()+main = do+#ifndef WITH_NOSQL+# ifdef WITH_SQLITE+ handle (\(_ :: IOException) -> return ())+ $ removeFile $ fromText sqlite_database_file+# endif++ runConn $ do+ mapM_ setup+ [ PersistentTest.testMigrate+ , PersistentTest.noPrefixMigrate+ , EmbedTest.embedMigrate+ , EmbedOrderTest.embedOrderMigrate+ , LargeNumberTest.numberMigrate+ , UniqueTest.uniqueMigrate+ , MaxLenTest.maxlenMigrate+ , Recursive.recursiveMigrate+ , CompositeTest.compositeMigrate+# ifdef WITH_SQLITE+ , MigrationTest.migrationMigrate+# endif+ , PersistUniqueTest.migration+ , RenameTest.migration+ , CustomPersistFieldTest.customFieldMigrate+# ifndef WITH_MYSQL+ , PrimaryTest.migration+# endif+# ifdef WITH_MYSQL+ , InsertDuplicateUpdate.duplicateMigrate+ , MigrationIdempotencyTest.migration+# endif+ , CustomPrimaryKeyReferenceTest.migration+ , MigrationColumnLengthTest.migration+ ]+ PersistentTest.cleanDB+#endif++ hspec $ do+ RenameTest.specs+ DataTypeTest.specs+ HtmlTest.specs+ EmbedTest.specs+ EmbedOrderTest.specs+ LargeNumberTest.specs+ UniqueTest.specs+ MaxLenTest.specs+ Recursive.specs+ SumTypeTest.specs+ MigrationOnlyTest.specs+ PersistentTest.specs+ EmptyEntityTest.specs+ CompositeTest.specs+ PersistUniqueTest.specs+ PrimaryTest.specs+ CustomPersistFieldTest.specs+ CustomPrimaryKeyReferenceTest.specs+ InsertDuplicateUpdate.specs+ MigrationColumnLengthTest.specs+ EquivalentTypeTest.specs++#ifdef WITH_SQLITE+ MigrationTest.specs+#endif+#ifdef WITH_MYSQL+ MigrationIdempotencyTest.specs+#endif