{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards, UndecidableInstances #-} module PersistentTest ( module PersistentTest , cleanDB , testMigrate , noPrefixMigrate , customPrefixMigrate , treeMigrate ) where import Control.Monad.Fail import Control.Monad.IO.Class import Data.Aeson import Data.Conduit import qualified Data.Conduit.List as CL import Data.Functor.Constant import Data.Functor.Identity import qualified Data.Map as Map import Data.Maybe (fromJust) import Test.Hspec.QuickCheck(prop) import Test.HUnit hiding (Test) import UnliftIO (MonadUnliftIO, catch) import Web.PathPieces (PathPiece (..)) import Data.Proxy (Proxy(..)) import Database.Persist import Init import PersistentTestModels import PersistTestPetType import PersistTestPetCollarType catchPersistException :: (MonadUnliftIO m, MonadFail m) => m a -> b -> m b catchPersistException action errValue = do Left res <- (Right `fmap` action) `catch` (\(_::PersistException) -> return $ Left errValue) return res filterOrSpecs :: forall m backend. Runner backend m => RunDb backend m -> Spec filterOrSpecs runDb = describe "FilterOr" $ do it "FilterOr []" $ runDb $ do let p = Person "z" 1 Nothing insert_ p ps <- selectList [FilterOr []] [Desc PersonAge] assertEmpty ps it "||. []" $ runDb $ do let p = Person "z" 1 Nothing insert_ p c <- count $ [PersonName ==. "a"] ||. [] c @== (1::Int) -- Test proper polymorphism _polymorphic :: (MonadFail m, MonadIO m, PersistQuery backend, BaseBackend backend ~ PersistEntityBackend Pet) => ReaderT backend m () _polymorphic = do ((Entity id' _):_) <- selectList [] [LimitTo 1] _ <- selectList [PetOwnerId ==. id'] [] insert_ $ Pet id' "foo" Cat return () -- Some lens stuff type ASetter s t a b = (a -> Identity b) -> s -> Identity t set :: ASetter s t a b -> b -> s -> t set l b = runIdentity . (l (\_ -> Identity b)) type Getting r s t a b = (a -> Constant r b) -> s -> Constant r t view :: s -> Getting a s t a b -> a view s l = getConstant (l Constant s) safeToRemoveSpec :: forall backend m. Runner backend m => RunDb backend m -> Spec safeToRemoveSpec runDb = do describe "DudeWeirdColumns" $ do it "can insert and get" $ do let m = DudeWeirdColumns "hello" runDb $ do k <- insert m mval <- get k liftIO $ fmap dudeWeirdColumnsName mval `shouldBe` Just "hello" it "can putMany" $ do let ms = [ DudeWeirdColumns "hello" , DudeWeirdColumns "goodbyue" ] runDb $ putMany ms specsWith :: forall backend m. Runner backend m => RunDb backend m -> Spec specsWith runDb = describe "persistent" $ do describe "SafeToRemove" (safeToRemoveSpec runDb) it "fieldLens" $ do let michael = Entity undefined $ Person "Michael" 28 Nothing :: Entity Person michaelP1 = Person "Michael" 29 Nothing :: Person view michael (fieldLens PersonAge) @?= 28 entityVal (set (fieldLens PersonAge) 29 michael) @?= michaelP1 it "FilterAnd []" $ runDb $ do let p = Person "z" 1 Nothing insert_ p ps <- selectList [FilterAnd []] [Desc PersonAge] assertNotEmpty ps it "Filter In" $ runDb $ do _ <- selectList [Filter PersonName (FilterValues ["Kostas"]) In] [] return () it "order of opts is irrelevant" $ runDb $ do let eq (a, b, _) (c, d) = (a, b) @== (c, d) limitOffsetOrder' :: [SelectOpt Person] -> (Int, Int, [SelectOpt Person]) limitOffsetOrder' = limitOffsetOrder limitOffsetOrder' [Desc PersonAge] `eq` (0, 0) limitOffsetOrder' [LimitTo 2, Desc PersonAge] `eq` (2, 0) limitOffsetOrder' [Desc PersonAge, LimitTo 2] `eq` (2, 0) limitOffsetOrder' [LimitTo 2, Desc PersonAge, OffsetBy 3] `eq` (2, 3) insertMany_ [ Person "z" 1 Nothing , Person "y" 2 Nothing , Person "x" 1 Nothing , Person "w" 2 Nothing , Person "v" 1 Nothing , Person "u" 2 Nothing ] a <- map (personName . entityVal) <$> selectList [] [Desc PersonAge, Asc PersonName, OffsetBy 2, LimitTo 3] a @== ["y", "v", "x"] b <- map (personName . entityVal) <$> selectList [] [OffsetBy 2, Desc PersonAge, LimitTo 3, Asc PersonName] b @== a c <- map (personName . entityVal) <$> selectList [] [OffsetBy 2, Desc PersonAge, LimitTo 3, Asc PersonName, LimitTo 1, OffsetBy 1] c @== a it "passes the general tests" $ runDb $ do let mic26 = Person "Michael" 26 Nothing micK <- insert mic26 results <- selectList [PersonName ==. "Michael"] [] results @== [Entity micK mic26] results' <- selectList [PersonAge <. 28] [] results' @== [Entity micK mic26] p28 <- updateGet micK [PersonAge =. 28] personAge p28 @== 28 updateWhere [PersonName ==. "Michael"] [PersonAge =. 29] uc <- count [PersonName ==. "Michael"] uc @== 1 Just mic29 <- get micK personAge mic29 @== 29 let louis = Person "Louis" 55 $ Just "brown" ex0 <- exists [PersonName ==. "Louis"] ex0 @== False louisK <- insert louis ex1 <- exists [PersonName ==. "Louis"] ex1 @== True delete louisK let eli = Person "Eliezer" 2 $ Just "blue" insert_ eli pasc <- selectList [] [Asc PersonAge] map entityVal pasc @== [eli, mic29] let abe30 = Person "Abe" 30 $ Just "black" insert_ abe30 -- pdesc <- selectList [PersonAge <. 30] [Desc PersonName] map entityVal pasc @== [eli, mic29] abes <- selectList [PersonName ==. "Abe"] [] map entityVal abes @== [abe30] Just (Entity _ p3) <- getBy $ PersonNameKey "Michael" p3 @== mic29 ps <- selectList [PersonColor ==. Just "blue"] [] map entityVal ps @== [eli] ps2 <- selectList [PersonColor ==. Nothing] [] map entityVal ps2 @== [mic29] delete micK Nothing <- get micK return () it "persistIdField" $ runDb $ do let p = Person "foo" 100 (Just "blue") q = Person "bar" 101 Nothing pk <- insert p qk <- insert q mp <- selectFirst [persistIdField ==. pk] [] fmap entityVal mp @== Just p mq <- selectFirst [persistIdField ==. qk] [] fmap entityVal mq @== Just q it "!=." $ runDb $ do deleteWhere ([] :: [Filter (PersonGeneric backend)]) let mic = Person "Michael" 25 Nothing insert_ mic let eli = Person "Eliezer" 25 (Just "Red") insert_ eli pne <- selectList [PersonName !=. "Michael"] [] map entityVal pne @== [eli] ps <- selectList [PersonColor !=. Nothing] [] map entityVal ps @== [eli] pnm <- selectList [PersonName !=. "Eliezer"] [] map entityVal pnm @== [mic] it "Double Maybe" $ runDb $ do deleteWhere ([] :: [Filter (PersonMayGeneric backend)]) let mic = PersonMay (Just "Michael") Nothing insert_ mic let eli = PersonMay (Just "Eliezer") (Just "Red") insert_ eli pe <- selectList [PersonMayName ==. Nothing, PersonMayColor ==. Nothing] [] map entityVal pe @== [] pne <- selectList [PersonMayName !=. Nothing, PersonMayColor !=. Nothing] [] map entityVal pne @== [eli] it "and/or" $ runDb $ do deleteWhere ([] :: [Filter (Person1Generic backend)]) insertMany_ [ Person1 "Michael" 25 , Person1 "Miriam" 25 , Person1 "Michael" 30 , Person1 "Michael" 35 ] c10 <- count $ [Person1Name ==. "Michael"] ||. [Person1Name ==. "Miriam", Person1Age ==. 25] c10 @== 4 c12 <- count [FilterOr [FilterAnd [Person1Name ==. "Michael"], FilterAnd [Person1Name ==. "Miriam"]]] c12 @== 4 c14 <- count [FilterOr [FilterAnd [Person1Name ==. "Michael"], FilterAnd [Person1Name ==. "Miriam"], FilterAnd [Person1Age >. 29, Person1Age <=. 30]]] c14 @== 4 c20 <- count $ [Person1Name ==. "Miriam"] ||. [Person1Age >. 29, Person1Age <=. 30] c20 @== 2 c22 <- count $ [Person1Age <=. 30] ++ [Person1Age >. 29] c22 @== 1 c24 <- count $ [FilterAnd [Person1Age <=. 30, Person1Age >. 29]] c24 @== 1 c26 <- count $ [Person1Age <=. 30] ++ [Person1Age >. 29] c26 @== 1 c34 <- count $ [Person1Name ==. "Michael"] ||. [Person1Name ==. "Mirieam"] ++ [Person1Age <.35] c34 @== 3 c30 <- count $ ([Person1Name ==. "Michael"] ||. [Person1Name ==. "Miriam"]) ++ [Person1Age <.35] c30 @== 3 c36 <- count $ [Person1Name ==. "Michael"] ||. ([Person1Name ==. "Miriam"] ++ [Person1Age <.35]) c36 @== 4 c40 <- count $ ([Person1Name ==. "Michael"] ||. [Person1Name ==. "Miriam"] ||. [Person1Age <.35]) c40 @== 4 it "deleteWhere" $ runDb $ do key2 <- insert $ Person "Michael2" 90 Nothing _ <- insert $ Person "Michael3" 90 Nothing let p91 = Person "Michael4" 91 Nothing key91 <- insert p91 ps90 <- selectList [PersonAge ==. 90] [] assertNotEmpty ps90 deleteWhere [PersonAge ==. 90] ps90' <- selectList [PersonAge ==. 90] [] assertEmpty ps90' Nothing <- get key2 Just p2_91 <- get key91 p91 @== p2_91 it "deleteBy" $ runDb $ do insert_ $ Person "Michael2" 27 Nothing let p3 = Person "Michael3" 27 Nothing key3 <- insert p3 ps2 <- selectList [PersonName ==. "Michael2"] [] assertNotEmpty ps2 deleteBy $ PersonNameKey "Michael2" ps2' <- selectList [PersonName ==. "Michael2"] [] assertEmpty ps2' Just p32 <- get key3 p3 @== p32 it "delete" $ runDb $ do key2 <- insert $ Person "Michael2" 27 Nothing let p3 = Person "Michael3" 27 Nothing key3 <- insert p3 pm2 <- selectList [PersonName ==. "Michael2"] [] assertNotEmpty pm2 delete key2 pm2' <- selectList [PersonName ==. "Michael2"] [] assertEmpty pm2' Just p <- get key3 p3 @== p prop "toPathPiece . fromPathPiece" $ \piece -> let key1 = piece :: (BackendKey SqlBackend) key2 = fromJust $ fromPathPiece $ toPathPiece key1 :: (BackendKey SqlBackend) in toPathPiece key1 == toPathPiece key2 it "replace" $ runDb $ do key2 <- insert $ Person "Michael2" 27 Nothing let p3 = Person "Michael3" 27 Nothing replace key2 p3 Just p <- get key2 p @== p3 -- test replace an empty key delete key2 Nothing <- get key2 _ <- replace key2 p3 Nothing <- get key2 return () let mic = Person "Michael" 25 Nothing micK <- insert mic Just p1 <- get micK p1 @== mic replace micK $ Person "Michael" 25 Nothing Just p2 <- get micK p2 @== mic replace micK $ Person "Michael" 26 Nothing Just mic26 <- get micK mic26 @/= mic personAge mic26 @== personAge mic + 1 it "getBy" $ runDb $ do let p2 = Person "Michael2" 27 Nothing key2 <- insert p2 Just (Entity k p) <- getBy $ PersonNameKey "Michael2" p @== p2 k @== key2 Nothing <- getBy $ PersonNameKey "Michael9" Just (Entity k' p') <- getByValue p2 k' @== k p' @== p return () it "updateGet" $ runDb $ do let p25 = Person "Michael" 25 Nothing key25 <- insert p25 pBlue28 <- updateGet key25 [PersonAge =. 28, PersonName =. "Updated"] pBlue28 @== Person "Updated" 28 Nothing pBlue30 <- updateGet key25 [PersonAge +=. 2] pBlue30 @== Person "Updated" 30 Nothing describe "repsertMany" $ do it "adds new rows when no conflicts" $ runDb $ do ids@[johnId, janeId, aliceId, eveId] <- replicateM 4 $ liftIO (Person1Key `fmap` generateKey) let john = Person1 "john" 20 let jane = Person1 "jane" 18 let alice = Person1 "alice" 18 let eve = Person1 "eve" 19 insertKey johnId john insertKey janeId jane _ <- repsertMany [ (aliceId, alice), (eveId, eve) ] es <- getMany ids let rs = [john, jane, alice, eve] es @== Map.fromList (zip ids rs) mapM_ delete ids it "handles conflicts by replacing old keys with new records" $ runDb $ do let john = Person1 "john" 20 let jane = Person1 "jane" 18 let alice = Person1 "alice" 18 let eve = Person1 "eve" 19 johnId <- insert john janeId <- insert jane _ <- repsertMany [ (johnId, alice), (janeId, eve) ] (Just alice') <- get johnId (Just eve') <- get janeId [alice',eve'] @== [alice,eve] mapM_ delete [johnId, janeId] it "updateWhere" $ runDb $ do let p1 = Person "Michael" 25 Nothing let p2 = Person "Michael2" 25 Nothing key1 <- insert p1 key2 <- insert p2 updateWhere [PersonName ==. "Michael2"] [PersonAge +=. 3, PersonName =. "Updated"] Just pBlue28 <- get key2 pBlue28 @== Person "Updated" 28 Nothing Just p <- get key1 p @== p1 it "selectList" $ runDb $ do let p25 = Person "Michael" 25 Nothing let p26 = Person "Michael2" 26 Nothing [key25, key26] <- insertMany [p25, p26] ps1 <- selectList [] [Asc PersonAge] ps1 @== [(Entity key25 p25), (Entity key26 p26)] -- limit ps2 <- selectList [] [Asc PersonAge, LimitTo 1] ps2 @== [(Entity key25 p25)] -- offset ps3 <- selectList [] [Asc PersonAge, OffsetBy 1] ps3 @== [(Entity key26 p26)] -- limit & offset ps4 <- selectList [] [Asc PersonAge, LimitTo 1, OffsetBy 1] ps4 @== [(Entity key26 p26)] ps5 <- selectList [] [Desc PersonAge] ps5 @== [(Entity key26 p26), (Entity key25 p25)] ps6 <- selectList [PersonAge ==. 26] [] ps6 @== [(Entity key26 p26)] it "selectSource" $ runDb $ do let p1 = Person "selectSource1" 1 Nothing p2 = Person "selectSource2" 2 Nothing p3 = Person "selectSource3" 3 Nothing [k1,k2,k3] <- insertMany [p1, p2, p3] ps1 <- runConduitRes $ selectSource [] [Desc PersonAge] .| await ps1 @== Just (Entity k3 p3) ps2 <- runConduitRes $ selectSource [PersonAge <. 3] [Asc PersonAge] .| CL.consume ps2 @== [Entity k1 p1, Entity k2 p2] runConduitRes $ selectSource [] [Desc PersonAge] .| do e1 <- await e1 @== Just (Entity k3 p3) e2 <- await e2 @== Just (Entity k2 p2) e3 <- await e3 @== Just (Entity k1 p1) e4 <- await e4 @== Nothing it "selectFirst" $ runDb $ do insert_ $ Person "Michael" 26 Nothing let pOld = Person "Oldie" 75 Nothing kOld <- insert pOld x <- selectFirst [] [Desc PersonAge] x @== Just (Entity kOld pOld) it "selectKeys" $ runDb $ do let p1 = Person "selectKeys1" 1 Nothing p2 = Person "selectKeys2" 2 Nothing p3 = Person "selectKeys3" 3 Nothing [k1,k2,k3] <- insertMany [p1, p2, p3] ps1 <- runConduitRes $ selectKeys [] [Desc PersonAge] .| await ps1 @== Just k3 ps2 <- runConduitRes $ selectKeys [PersonAge <. 3] [Asc PersonAge] .| CL.consume ps2 @== [k1, k2] runConduitRes $ selectKeys [] [Desc PersonAge] .| do e1 <- await e1 @== Just k3 e2 <- await e2 @== Just k2 e3 <- await e3 @== Just k1 e4 <- await e4 @== Nothing it "insertMany_ with no arguments" $ runDb $ do _ <- insertMany_ ([] :: [PersonGeneric backend]) rows <- (count ([] :: [Filter (PersonGeneric backend)]) :: ReaderT backend m Int) rows @== 0 _ <- insertMany ([] :: [PersonGeneric backend]) rows2 <- count ([] :: [Filter (PersonGeneric backend)]) rows2 @== 0 _ <- insertEntityMany ([] :: [Entity (PersonGeneric backend)]) rows3 <- count ([] :: [Filter (PersonGeneric backend)]) rows3 @== 0 it "insertEntityMany" $ runDb $ do id1:id2:id3:id4:id5:[] <- liftIO $ replicateM 5 (PersonKey `fmap` generateKey) let p1 = Entity id1 $ Person "insertEntityMany1" 1 Nothing p2 = Entity id2 $ Person "insertEntityMany2" 2 Nothing p3 = Entity id3 $ Person "insertEntityMany3" 3 Nothing p4 = Entity id4 $ Person "insertEntityMany4" 3 Nothing p5 = Entity id5 $ Person "insertEntityMany5" 3 Nothing insertEntityMany [p1,p2,p3,p4,p5] rows <- count ([] :: [Filter (PersonGeneric backend)]) rows @== 5 it "insertBy" $ runDb $ do Right _ <- insertBy $ Person "name" 1 Nothing Left _ <- insertBy $ Person "name" 1 Nothing Right _ <- insertBy $ Person "name2" 1 Nothing return () it "insertKey" $ runDb $ do k <- liftIO (PersonKey `fmap` generateKey) insertKey k $ Person "Key" 26 Nothing Just (Entity k2 _) <- selectFirst [PersonName ==. "Key"] [] k2 @== k it "insertEntity" $ runDb $ do Entity k p <- insertEntity $ Person "name" 1 Nothing Just p2 <- get k p2 @== p it "insertRecord" $ runDb $ do let record = Person "name" 1 Nothing record' <- insertRecord record record' @== record it "getEntity" $ runDb $ do Entity k p <- insertEntity $ Person "name" 1 Nothing Just (Entity k2 p2) <- getEntity k p @== p2 k @== k2 it "getJustEntity" $ runDb $ do let p1 = Person "name" 1 Nothing k1 <- insert p1 Entity k2 p2 <- getJustEntity k1 p1 @== p2 k1 @== k2 it "repsert" $ runDb $ do k <- liftIO (PersonKey `fmap` generateKey) Nothing <- selectFirst [PersonName ==. "Repsert"] [] repsert k $ Person "Repsert" 26 Nothing Just (Entity k2 _) <- selectFirst [PersonName ==. "Repsert"] [] k2 @== k repsert k $ Person "Repsert" 27 Nothing Just (Entity k3 p) <- selectFirst [PersonName ==. "Repsert"] [] k3 @== k 27 @== personAge p it "retrieves a belongsToJust association" $ runDb $ do let p = Person "pet owner" 30 Nothing person <- insert p let cat = Pet person "Mittens" Cat p2 <- getJust $ petOwnerId cat p @== p2 p3 <- belongsToJust petOwnerId cat p @== p3 it "retrieves a belongsTo association" $ runDb $ do let p = Person "pet owner" 30 Nothing person <- insert p let cat = MaybeOwnedPet (Just person) "Mittens" Cat p2 <- getJust $ fromJust $ maybeOwnedPetOwnerId cat p @== p2 Just p4 <- belongsTo maybeOwnedPetOwnerId cat p @== p4 it "derivePersistField" $ runDb $ do person <- insert $ Person "pet owner" 30 Nothing catKey <- insert $ Pet person "Mittens" Cat Just cat' <- get catKey liftIO $ petType cat' @?= Cat dog <- insert $ Pet person "Spike" Dog Just dog' <- get dog liftIO $ petType dog' @?= Dog it "derivePersistFieldJSON" $ runDb $ do let mittensCollar = PetCollar "Mittens\n1-714-668-9672" True pkey <- insert $ Person "pet owner" 30 Nothing catKey <- insert $ OutdoorPet pkey mittensCollar Cat Just (OutdoorPet _ collar' _) <- get catKey liftIO $ collar' @?= mittensCollar it "idIn" $ runDb $ do let p1 = Person "D" 0 Nothing p2 = Person "E" 1 Nothing p3 = Person "F" 2 Nothing pid1 <- insert p1 insert_ p2 pid3 <- insert p3 x <- selectList [PersonId <-. [pid1, pid3]] [] liftIO $ x @?= [Entity pid1 p1, Entity pid3 p3] it "In" $ runDb $ do let p1 = Person "D" 0 Nothing p2 = Person "E" 1 Nothing p3 = Person "F" 2 (Just "blue") insert_ p1 insert_ p2 insert_ p3 x1 <- fmap entityVal `fmap` selectList [PersonName <-. ["D"]] [] liftIO $ x1 @?= [p1] x2 <- fmap entityVal `fmap` selectList [PersonName /<-. ["D"]] [] liftIO $ x2 @?= [p2, p3] x3 <- fmap entityVal `fmap` selectList [PersonColor <-. [Just "blue"]] [] liftIO $ x3 @?= [p3] x4 <- fmap entityVal `fmap` selectList [PersonColor /<-. [Just "blue"]] [] liftIO $ x4 @?= [p1, p2] x5 <- fmap entityVal `fmap` selectList [PersonColor <-. [Nothing, Just "blue"]] [] liftIO $ x5 @?= [p1, p2, p3] x6 <- fmap entityVal `fmap` selectList [PersonColor /<-. [Nothing]] [] liftIO $ x6 @?= [p3] describe "toJSON" $ do it "serializes" $ runDb $ do let p = Person "D" 0 Nothing k <- insert p liftIO $ toJSON (Entity k p) @?= object [("id", toJSON k), ("color",Null),("name",String "D"),("age",Number 0)] {- FIXME prop "fromJSON . toJSON $ key" $ \(person :: Key Person) -> case (fromJSON . toJSON) person of Success p -> p == person _ -> error "fromJSON" -} describe "strictness" $ do it "bang" $ (return $! Strict (error "foo") 5 5) `shouldThrow` anyErrorCall it "tilde" $ void (return $! Strict 5 (error "foo") 5 :: IO Strict) it "blank" $ (return $! Strict 5 5 (error "foo")) `shouldThrow` anyErrorCall describe "documentation syntax" $ do let edef = entityDef (Proxy :: Proxy Relationship) it "provides comments on entity def" $ do getEntityComments edef `shouldBe` Just "This is a doc comment for a relationship.\nYou need to put the pipe character for each line of documentation.\nBut you can resume the doc comments afterwards.\n" it "provides comments on the field" $ do let [nameField, _] = getEntityFields edef fieldComments nameField `shouldBe` Just "Fields should be documentable.\n"