persistent-qq 2.9.1 → 2.9.1.1
raw patch · 7 files changed
+385/−9 lines, 7 filesdep +HUnitdep +aesondep +fast-loggerdep −semigroupsdep ~basedep ~persistentPVP ok
version bump matches the API change (PVP)
Dependencies added: HUnit, aeson, fast-logger, hspec, monad-logger, persistent-qq, persistent-sqlite, persistent-template, resourcet, unliftio
Dependencies removed: semigroups
Dependency ranges changed: base, persistent
API changes (from Hackage documentation)
Files
- ChangeLog.md +4/−0
- persistent-qq.cabal +33/−7
- src/Database/Persist/Sql/Raw/QQ.hs +0/−2
- test/PersistTestPetCollarType.hs +15/−0
- test/PersistTestPetType.hs +8/−0
- test/PersistentTestModels.hs +170/−0
- test/Spec.hs +155/−0
ChangeLog.md view
@@ -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)
persistent-qq.cabal view
@@ -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 <http://www.stackage.org/package/persistent>. 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
src/Database/Persist/Sql/Raw/QQ.hs view
@@ -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
+ test/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"
+ test/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"
+ test/PersistentTestModels.hs view
@@ -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)])
+ test/Spec.hs view
@@ -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) ]