diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Changelog for persistent-qq +## 2.9.1.1 + +* Compatibility with latest persistent-template for test suite [#1002](https://github.com/yesodweb/persistent/pull/1002/files) + ## 2.9.1 * Added support for list of values in `sqlQQ`. [#819](https://github.com/yesodweb/persistent/pull/819) diff --git a/persistent-qq.cabal b/persistent-qq.cabal --- a/persistent-qq.cabal +++ b/persistent-qq.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 9d1539e33f41bc20d3eaf4418ed42bdffc6936808b93c84ae04445144ef549a8 +-- hash: bef2b585278826bc60fe813d4918833dc06cec43f2a8e4567190448ccfdee163 name: persistent-qq -version: 2.9.1 +version: 2.9.1.1 synopsis: Provides a quasi-quoter for raw SQL for persistent description: Please see README and API docs at . category: Database, Yesod @@ -35,13 +35,39 @@ src ghc-options: -Wall build-depends: - base >=4.7 && <5 + base >=4.9 && <5 , haskell-src-meta , mtl - , persistent >=2.9 + , persistent >=2.10 , template-haskell , text - if impl(ghc < 8) - build-depends: - semigroups + default-language: Haskell2010 + +test-suite specs + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + PersistentTestModels + PersistTestPetCollarType + PersistTestPetType + hs-source-dirs: + test + ghc-options: -Wall + build-depends: + HUnit + , aeson + , base + , fast-logger + , haskell-src-meta + , hspec + , monad-logger + , mtl + , persistent >=2.10 + , persistent-qq + , persistent-sqlite + , persistent-template + , resourcet + , template-haskell + , text + , unliftio default-language: Haskell2010 diff --git a/src/Database/Persist/Sql/Raw/QQ.hs b/src/Database/Persist/Sql/Raw/QQ.hs --- a/src/Database/Persist/Sql/Raw/QQ.hs +++ b/src/Database/Persist/Sql/Raw/QQ.hs @@ -14,12 +14,10 @@ that allows value substitutions, table name substitutions as well as column name substitutions. -} - {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} - module Database.Persist.Sql.Raw.QQ ( -- * Sql QuasiQuoters queryQQ diff --git a/test/PersistTestPetCollarType.hs b/test/PersistTestPetCollarType.hs new file mode 100644 --- /dev/null +++ b/test/PersistTestPetCollarType.hs @@ -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" diff --git a/test/PersistTestPetType.hs b/test/PersistTestPetType.hs new file mode 100644 --- /dev/null +++ b/test/PersistTestPetType.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} +module PersistTestPetType where + +import Database.Persist.TH + +data PetType = Cat | Dog + deriving (Show, Read, Eq) +derivePersistField "PetType" diff --git a/test/PersistentTestModels.hs b/test/PersistentTestModels.hs new file mode 100644 --- /dev/null +++ b/test/PersistentTestModels.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- FIXME +{-# LANGUAGE DerivingStrategies #-} +module PersistentTestModels where + +import Control.Monad.Reader +import Data.Aeson +import Data.Text (Text) + +import Database.Persist.Sql +import Database.Persist.TH +import PersistTestPetType +import PersistTestPetCollarType + +share + [ mkPersist sqlSettings { mpsGeneric = True } + , mkMigrate "testMigrate" + ] [persistUpperCase| + +-- 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 + deriving Show Eq + 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 sqlSettings { mpsPrefixFields = False, mpsGeneric = True } + , mkMigrate "noPrefixMigrate" + ] [persistLowerCase| +NoPrefix1 + someFieldName Int +NoPrefix2 + someOtherFieldName Int + unprefixedRef NoPrefix1Id ++NoPrefixSum + unprefixedLeft Int + unprefixedRight String + deriving Show Eq +|] + +deriving instance Show (BackendKey backend) => Show (NoPrefix1Generic backend) +deriving instance Eq (BackendKey backend) => Eq (NoPrefix1Generic backend) + +deriving instance Show (BackendKey backend) => Show (NoPrefix2Generic backend) +deriving instance Eq (BackendKey backend) => Eq (NoPrefix2Generic backend) + +-- | 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" + +cleanDB + :: (MonadIO m, PersistQuery backend, PersistStoreWrite (BaseBackend backend)) + => ReaderT backend m () +cleanDB = do + deleteWhere ([] :: [Filter (PersonGeneric backend)]) + deleteWhere ([] :: [Filter (Person1Generic backend)]) + deleteWhere ([] :: [Filter (PetGeneric backend)]) + deleteWhere ([] :: [Filter (MaybeOwnedPetGeneric backend)]) + deleteWhere ([] :: [Filter (NeedsPetGeneric backend)]) + deleteWhere ([] :: [Filter (OutdoorPetGeneric backend)]) + deleteWhere ([] :: [Filter (UserPTGeneric backend)]) + deleteWhere ([] :: [Filter (EmailPTGeneric backend)]) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeFamilies #-} + +import Control.Monad.Logger +import Control.Monad.Trans.Resource +import Control.Monad.Reader +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Text (Text) +import System.Log.FastLogger +import Test.Hspec +import Test.HUnit ((@?=)) +import UnliftIO + +import Database.Persist.Sql +import Database.Persist.Sql.Raw.QQ +import Database.Persist.Sqlite +import PersistTestPetType +import PersistentTestModels + +main :: IO () +main = hspec specs + +_debugOn :: Bool +_debugOn = False + +sqlite_database_file :: Text +sqlite_database_file = "testdb.sqlite3" +sqlite_database :: SqliteConnectionInfo +sqlite_database = mkSqliteConnectionInfo sqlite_database_file + +runConn :: MonadUnliftIO m => SqlPersistT (LoggingT m) t -> m () +runConn f = do + let debugPrint = _debugOn + let printDebug = if debugPrint then print . fromLogStr else void . return + flip runLoggingT (\_ _ _ s -> printDebug s) $ do + _ <- withSqlitePoolInfo sqlite_database 1 $ runSqlPool f + return () + +db :: SqlPersistT (LoggingT (ResourceT IO)) () -> IO () +db actions = do + runResourceT $ runConn $ do + runMigration testMigrate + actions + transactionUndo + +specs :: Spec +specs = describe "persistent-qq" $ do + it "sqlQQ/?-?" $ db $ do + ret <- [sqlQQ| SELECT #{2 :: Int}+#{2 :: Int} |] + liftIO $ ret @?= [Single (4::Int)] + + it "sqlQQ/?-?" $ db $ do + ret <- [sqlQQ| SELECT #{5 :: Int}-#{3 :: Int} |] + liftIO $ ret @?= [Single (2::Int)] + + it "sqlQQ/NULL" $ db $ do + ret <- [sqlQQ| SELECT NULL |] + liftIO $ ret @?= [Nothing :: Maybe (Single Int)] + + 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) => 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 "sqlQQ/values syntax" $ 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 (Just "red") + (_ , _ ) <- insert' $ Person "Norbert" 44 (Just "green") + (p3k, p3) <- insert' $ Person "Cassandra" 19 (Just "blue") + (_ , _ ) <- insert' $ Person "Thiago" 19 (Just "yellow") + let + colors = Just "blue" :| Just "red" : [] :: NonEmpty (Maybe Text) + ret <- [sqlQQ| + SELECT ?? + FROM ^{Person} + WHERE ^{Person}.@{PersonColor} IN %{colors} + |] + liftIO $ ret @?= [ (Entity p1k p1) + , (Entity p3k p3) ]