persistent-postgresql 2.9.1 → 2.10.0
raw patch · 9 files changed
+1178/−96 lines, 9 filesdep +HUnitdep +QuickCheckdep +fast-loggerdep ~aesondep ~basedep ~bytestring
Dependencies added: HUnit, QuickCheck, fast-logger, hspec, hspec-expectations, persistent-postgresql, persistent-qq, persistent-template, persistent-test, quickcheck-instances, unordered-containers, vector
Dependency ranges changed: aeson, base, bytestring, conduit, containers, monad-logger, persistent, postgresql-libpq, postgresql-simple, resourcet, text, time, transformers
Files
- ChangeLog.md +8/−1
- Database/Persist/Postgresql.hs +60/−73
- Database/Persist/Postgresql/JSON.hs +199/−6
- persistent-postgresql.cabal +52/−16
- test/ArrayAggTest.hs +53/−0
- test/EquivalentTypeTestPostgres.hs +44/−0
- test/JSONTest.hs +467/−0
- test/PgInit.hs +119/−0
- test/main.hs +176/−0
ChangeLog.md view
@@ -1,5 +1,12 @@ # Changelog for persistent-postgresql +## 2.10.0++* Added question mark operators (`(?.), (?|.), (?&.)`) to `Database.Persist.Postgresql.JSON` [#863](https://github.com/yesodweb/persistent/pull/863)+* Changes to certain types:+ * `PersistValue`: added `PersistArray` data constructor+ * `Filter`: Changed the `filterValue :: Either a [a]` to `filterValue :: FilterValue`+ ## 2.9.1 * Add `openSimpleConnWithVersion` function. [#883](https://github.com/yesodweb/persistent/pull/883) @@ -10,7 +17,7 @@ ## 2.8.2 -Added module `Database.Persist.Postgres.JSON` [#793](https://github.com/yesodweb/persistent/pull/793)+Added module `Database.Persist.Postgresql.JSON` [#793](https://github.com/yesodweb/persistent/pull/793) * `PersistField` and `PersistFieldSql` instances for `Data.Aeson.Value` * Filter operators `(@>.)` and `(<@.)` to filter on JSON values
Database/Persist/Postgresql.hs view
@@ -1,15 +1,8 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE DeriveDataTypeable #-} -- | A postgresql backend for persistent. module Database.Persist.Postgresql@@ -31,61 +24,59 @@ , migrateEnableExtension ) where -import Database.Persist.Sql-import qualified Database.Persist.Sql.Util as Util-import Database.Persist.Sql.Types.Internal (mkPersistBackend)-import Data.Fixed (Pico)+import qualified Database.PostgreSQL.LibPQ as LibPQ import qualified Database.PostgreSQL.Simple as PG-import qualified Database.PostgreSQL.Simple.TypeInfo.Static as PS import qualified Database.PostgreSQL.Simple.Internal as PG-import qualified Database.PostgreSQL.Simple.ToField as PGTF import qualified Database.PostgreSQL.Simple.FromField as PGFF+import qualified Database.PostgreSQL.Simple.ToField as PGTF import qualified Database.PostgreSQL.Simple.Transaction as PG import qualified Database.PostgreSQL.Simple.Types as PG+import qualified Database.PostgreSQL.Simple.TypeInfo.Static as PS import Database.PostgreSQL.Simple.Ok (Ok (..)) -import qualified Database.PostgreSQL.LibPQ as LibPQ--import Control.Exception (throw)-import Control.Monad.IO.Unlift (MonadIO (..), MonadUnliftIO)-import Data.Data-import Data.Typeable (Typeable)-import Data.IORef-import qualified Data.Map as Map-import Data.Maybe-import Data.Either (partitionEithers) import Control.Arrow-import Data.List (find, sort, groupBy)-import Data.Function (on)-import Data.Conduit-import qualified Data.Conduit.List as CL+import Control.Exception (Exception, throw, throwIO)+import Control.Monad (forM)+import Control.Monad.IO.Unlift (MonadIO (..), MonadUnliftIO) import Control.Monad.Logger (MonadLogger, runNoLoggingT)--import qualified Data.IntMap as I+import Control.Monad.Trans.Reader (runReaderT)+import Control.Monad.Trans.Writer (WriterT(..), runWriterT) -import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as B8-import qualified Data.Text as T-import Data.Text.Read (rational)-import qualified Data.Text.Encoding as T-import qualified Data.Text.IO as T import qualified Blaze.ByteString.Builder.Char8 as BBB--import Data.Text (Text)+import Data.Acquire (Acquire, mkAcquire, with) import Data.Aeson import Data.Aeson.Types (modifyFailure)-import Control.Monad (forM)-import Control.Monad.Trans.Reader (runReaderT)-import Control.Monad.Trans.Writer (WriterT(..), runWriterT)-import Data.Acquire (Acquire, mkAcquire, with)-import System.Environment (getEnvironment)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as B8+import Data.Conduit+import qualified Data.Conduit.List as CL+import Data.Data+import Data.Either (partitionEithers)+import Data.Fixed (Pico)+import Data.Function (on) import Data.Int (Int64)+import qualified Data.IntMap as I+import Data.IORef+import Data.List (find, sort, groupBy)+import Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NEL+import qualified Data.Map as Map+import Data.Maybe import Data.Monoid ((<>)) import Data.Pool (Pool)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.IO as T+import Data.Text.Read (rational) import Data.Time (utc, localTimeToUTC)-import Control.Exception (Exception, throwIO)+import Data.Typeable (Typeable)+import System.Environment (getEnvironment) +import Database.Persist.Sql+import qualified Database.Persist.Sql.Util as Util+ -- | A @libpq@ connection string. A simple example of connection -- string would be @\"host=localhost port=5432 user=test -- dbname=test password=test\"@. Please read libpq's@@ -108,13 +99,13 @@ -- finishes using it. Note that you should not use the given -- 'ConnectionPool' outside the action since it may already -- have been released.-withPostgresqlPool :: (MonadLogger m, MonadUnliftIO m, IsSqlBackend backend)+withPostgresqlPool :: (MonadLogger m, MonadUnliftIO m) => ConnectionString -- ^ Connection string to the database. -> Int -- ^ Number of connections to be kept open in -- the pool.- -> (Pool backend -> m a)+ -> (Pool SqlBackend -> m a) -- ^ Action to be executed that uses the -- connection pool. -> m a@@ -124,7 +115,7 @@ -- the server version (to work around an Amazon Redshift bug). -- -- @since 2.6.2-withPostgresqlPoolWithVersion :: (MonadUnliftIO m, MonadLogger m, IsSqlBackend backend)+withPostgresqlPoolWithVersion :: (MonadUnliftIO m, MonadLogger m) => (PG.Connection -> IO (Maybe Double)) -- ^ Action to perform to get the server version. -> ConnectionString@@ -132,7 +123,7 @@ -> Int -- ^ Number of connections to be kept open in -- the pool.- -> (Pool backend -> m a)+ -> (Pool SqlBackend -> m a) -- ^ Action to be executed that uses the -- connection pool. -> m a@@ -142,13 +133,13 @@ -- responsibility to properly close the connection pool when -- unneeded. Use 'withPostgresqlPool' for an automatic resource -- control.-createPostgresqlPool :: (MonadUnliftIO m, MonadLogger m, IsSqlBackend backend)+createPostgresqlPool :: (MonadUnliftIO m, MonadLogger m) => ConnectionString -- ^ Connection string to the database. -> Int -- ^ Number of connections to be kept open -- in the pool.- -> m (Pool backend)+ -> m (Pool SqlBackend) createPostgresqlPool = createPostgresqlPoolModified (const $ return ()) -- | Same as 'createPostgresqlPool', but additionally takes a callback function@@ -160,11 +151,11 @@ -- -- @since 2.1.3 createPostgresqlPoolModified- :: (MonadUnliftIO m, MonadLogger m, IsSqlBackend backend)+ :: (MonadUnliftIO m, MonadLogger m) => (PG.Connection -> IO ()) -- ^ Action to perform after connection is created. -> ConnectionString -- ^ Connection string to the database. -> Int -- ^ Number of connections to be kept open in the pool.- -> m (Pool backend)+ -> m (Pool SqlBackend) createPostgresqlPoolModified = createPostgresqlPoolModifiedWithVersion getServerVersion -- | Same as other similarly-named functions in this module, but takes callbacks for obtaining@@ -173,37 +164,36 @@ -- -- @since 2.6.2 createPostgresqlPoolModifiedWithVersion- :: (MonadUnliftIO m, MonadLogger m, IsSqlBackend backend)+ :: (MonadUnliftIO m, MonadLogger m) => (PG.Connection -> IO (Maybe Double)) -- ^ Action to perform to get the server version. -> (PG.Connection -> IO ()) -- ^ Action to perform after connection is created. -> ConnectionString -- ^ Connection string to the database. -> Int -- ^ Number of connections to be kept open in the pool.- -> m (Pool backend)+ -> m (Pool SqlBackend) createPostgresqlPoolModifiedWithVersion getVer modConn ci = createSqlPool $ open' modConn getVer ci -- | Same as 'withPostgresqlPool', but instead of opening a pool -- of connections, only one connection is opened.-withPostgresqlConn :: (MonadUnliftIO m, MonadLogger m, IsSqlBackend backend)- => ConnectionString -> (backend -> m a) -> m a+withPostgresqlConn :: (MonadUnliftIO m, MonadLogger m)+ => ConnectionString -> (SqlBackend -> m a) -> m a withPostgresqlConn = withPostgresqlConnWithVersion getServerVersion -- | Same as 'withPostgresqlConn', but takes a callback for obtaining -- the server version (to work around an Amazon Redshift bug). -- -- @since 2.6.2-withPostgresqlConnWithVersion :: (MonadUnliftIO m, MonadLogger m, IsSqlBackend backend)+withPostgresqlConnWithVersion :: (MonadUnliftIO m, MonadLogger m) => (PG.Connection -> IO (Maybe Double)) -> ConnectionString- -> (backend -> m a)+ -> (SqlBackend -> m a) -> m a withPostgresqlConnWithVersion getVer = withSqlConn . open' (const $ return ()) getVer open'- :: (IsSqlBackend backend)- => (PG.Connection -> IO ())+ :: (PG.Connection -> IO ()) -> (PG.Connection -> IO (Maybe Double))- -> ConnectionString -> LogFunc -> IO backend+ -> ConnectionString -> LogFunc -> IO SqlBackend open' modConn getVer cstr logFunc = do conn <- PG.connectPostgreSQL cstr modConn conn@@ -235,14 +225,14 @@ -- | Generate a 'SqlBackend' from a 'PG.Connection'.-openSimpleConn :: (IsSqlBackend backend) => LogFunc -> PG.Connection -> IO backend+openSimpleConn :: LogFunc -> PG.Connection -> IO SqlBackend openSimpleConn = openSimpleConnWithVersion getServerVersion -- | Generate a 'SqlBackend' from a 'PG.Connection', but takes a callback for -- obtaining the server version. -- -- @since 2.9.1-openSimpleConnWithVersion :: (IsSqlBackend backend) => (PG.Connection -> IO (Maybe Double)) -> LogFunc -> PG.Connection -> IO backend+openSimpleConnWithVersion :: (PG.Connection -> IO (Maybe Double)) -> LogFunc -> PG.Connection -> IO SqlBackend openSimpleConnWithVersion getVer logFunc conn = do smap <- newIORef $ Map.empty serverVersion <- getVer conn@@ -250,10 +240,10 @@ -- | Create the backend given a logging function, server version, mutable statement cell, -- and connection.-createBackend :: IsSqlBackend backend => LogFunc -> Maybe Double- -> IORef (Map.Map Text Statement) -> PG.Connection -> backend+createBackend :: LogFunc -> Maybe Double+ -> IORef (Map.Map Text Statement) -> PG.Connection -> SqlBackend createBackend logFunc serverVersion smap conn = do- mkPersistBackend $ SqlBackend+ SqlBackend { connPrepare = prepare' conn , connStmtMap = smap , connInsertSql = insertSql'@@ -310,8 +300,8 @@ Nothing -> ISRSingle (sql <> " RETURNING " <> escape (fieldDB (entityId ent))) -upsertSql' :: EntityDef -> Text -> Text-upsertSql' ent updateVal = T.concat+upsertSql' :: EntityDef -> NonEmpty UniqueDef -> Text -> Text+upsertSql' ent uniqs updateVal = T.concat [ "INSERT INTO " , escape (entityDB ent) , "("@@ -327,7 +317,7 @@ , " RETURNING ??" ] where- wher = T.intercalate " AND " $ map singleCondition $ entityUniques ent+ wher = T.intercalate " AND " $ map singleCondition $ NEL.toList uniqs singleCondition :: UniqueDef -> Text singleCondition udef = T.intercalate " AND " (map singleClause $ map snd (uniqueFields udef))@@ -441,6 +431,7 @@ toField (P (PersistList l)) = PGTF.toField $ listToJSON l toField (P (PersistMap m)) = PGTF.toField $ mapToJSON m toField (P (PersistDbSpecific s)) = PGTF.toField (Unknown s)+ toField (P (PersistArray a)) = PGTF.toField $ PG.PGArray $ P <$> a toField (P (PersistObjectId _)) = error "Refusing to serialize a PersistObjectId to a PostgreSQL value" @@ -474,10 +465,6 @@ , (k PS.xml, convertPV PersistText) , (k PS.float4, convertPV PersistDouble) , (k PS.float8, convertPV PersistDouble)-#if !MIN_VERSION_postgresql_simple(0,5,0)- , (k PS.abstime, convertPV PersistUTCTime)- , (k PS.reltime, convertPV PersistUTCTime)-#endif , (k PS.money, convertPV PersistRational) , (k PS.bpchar, convertPV PersistText) , (k PS.varchar, convertPV PersistText)
Database/Persist/Postgresql/JSON.hs view
@@ -1,24 +1,29 @@-{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} -- | Filter operators for JSON values added to PostgreSQL 9.4 module Database.Persist.Postgresql.JSON ( (@>.) , (<@.)+ , (?.)+ , (?|.)+ , (?&.) , Value() ) where import Data.Aeson (FromJSON, ToJSON, Value, encode, eitherDecodeStrict) import qualified Data.ByteString.Lazy as BSL import Data.Proxy (Proxy)-import Data.Text as T (Text, pack, concat)+import Data.Text (Text)+import qualified Data.Text as T import Data.Text.Encoding as TE (encodeUtf8) import Database.Persist (EntityField, Filter(..), PersistValue(..), PersistField(..), PersistFilter(..)) import Database.Persist.Sql (PersistFieldSql(..), SqlType(..))+import Database.Persist.Types (FilterValue(..)) -infix 4 @>., <@.+infix 4 @>., <@., ?., ?|., ?&. -- | This operator checks inclusion of the JSON value -- on the right hand side in the JSON value on the left@@ -126,7 +131,7 @@ -- -- @since 2.8.2 (@>.) :: EntityField record Value -> Value -> Filter record-(@>.) field val = Filter field (Left val) $ BackendSpecificFilter " @> "+(@>.) field val = Filter field (FilterValue val) $ BackendSpecificFilter " @> " -- | Same as '@>.' except the inclusion check is reversed. -- i.e. is the JSON value on the left hand side included@@ -134,9 +139,189 @@ -- -- @since 2.8.2 (<@.) :: EntityField record Value -> Value -> Filter record-(<@.) field val = Filter field (Left val) $ BackendSpecificFilter " <@ "+(<@.) field val = Filter field (FilterValue val) $ BackendSpecificFilter " <@ " +-- | This operator takes a column and a string to find a+-- top-level key/field in an object.+--+-- @column ?. string@+--+-- N.B. This operator might have some unexpected interactions+-- with non-object values. Please reference the examples.+--+-- === __Objects__+--+-- @+-- {"a":null} ? "a" == True+-- {"test":false,"a":500} ? "a" == True+-- {"b":{"a":[]}} ? "a" == False+-- {} ? "a" == False+-- {} ? "{}" == False+-- {} ? "" == False+-- {"":9001} ? "" == True+-- @+--+-- === __Arrays__+--+-- This operator will match an array if the string to be matched+-- is an element of that array, but nothing else.+--+-- @+-- ["a"] ? "a" == True+-- [["a"]] ? "a" == False+-- [9,false,"1",null] ? "1" == True+-- [] ? "[]" == False+-- [{"a":true}] ? "a" == False+-- @+--+-- === __Other values__+--+-- This operator functions like an equivalence operator on strings only.+-- Any other value does not match.+--+-- @+-- "a" ? "a" == True+-- "1" ? "1" == True+-- "ab" ? "a" == False+-- 1 ? "1" == False+-- null ? "null" == False+-- true ? "true" == False+-- 1.5 ? "1.5" == False+-- @+--+-- @since 2.10.0+(?.) :: EntityField record Value -> Text -> Filter record+(?.) = jsonFilter " ?? " +-- | This operator takes a column and a list of strings to+-- test whether ANY of the elements of the list are top+-- level fields in an object.+--+-- @column ?|. list@+--+-- /N.B. An empty list __will never match anything__. Also, this+-- operator might have some unexpected interactions with+-- non-object values. Please reference the examples./+--+-- === __Objects__+--+-- @+-- {"a":null} ?| ["a","b","c"] == True+-- {"test":false,"a":500} ?| ["a","b","c"] == True+-- {} ?| ["a","{}"] == False+-- {"b":{"a":[]}} ?| ["a","c"] == False+-- {"b":{"a":[]},"test":null} ?| [] == False+-- @+--+-- === __Arrays__+--+-- This operator will match an array if __any__ of the elements+-- of the list are matching string elements of the array.+--+-- @+-- ["a"] ?| ["a","b","c"] == True+-- [["a"]] ?| ["a","b","c"] == False+-- [9,false,"1",null] ?| ["a","false"] == False+-- [] ?| ["a","b","c"] == False+-- [] ?| [] == False+-- [{"a":true}] ?| ["a","b","c"] == False+-- [null,4,"b",[]] ?| ["a","b","c"] == True+-- @+--+-- === __Other values__+--+-- This operator functions much like an equivalence operator+-- on strings only. If a string matches with __any__ element of+-- the given list, the comparison matches. No other values match.+--+-- @+-- "a" ?| ["a","b","c"] == True+-- "1" ?| ["a","b","1"] == True+-- "ab" ?| ["a","b","c"] == False+-- 1 ?| ["a","1"] == False+-- null ?| ["a","null"] == False+-- true ?| ["a","true"] == False+-- "a" ?| [] == False+-- @+--+-- @since 2.10.0+(?|.) :: EntityField record Value -> [Text] -> Filter record+(?|.) field = jsonFilter " ??| " field . PostgresArray++-- | This operator takes a column and a list of strings to+-- test whether ALL of the elements of the list are top+-- level fields in an object.+--+-- @column ?&. list@+--+-- /N.B. An empty list __will match anything__. Also, this+-- operator might have some unexpected interactions with+-- non-object values. Please reference the examples./+--+-- === __Objects__+--+-- @+-- {"a":null} ?& ["a"] == True+-- {"a":null} ?& ["a","a"] == True+-- {"test":false,"a":500} ?& ["a"] == True+-- {"test":false,"a":500} ?& ["a","b"] == False+-- {} ?& ["{}"] == False+-- {"b":{"a":[]}} ?& ["a"] == False+-- {"b":{"a":[]},"c":false} ?& ["a","c"] == False+-- {"a":1,"b":2,"c":3,"d":4} ?& ["b","d"] == True+-- {} ?& [] == True+-- {"b":{"a":[]},"test":null} ?& [] == True+-- @+--+-- === __Arrays__+--+-- This operator will match an array if __all__ of the elements+-- of the list are matching string elements of the array.+--+-- @+-- ["a"] ?& ["a"] == True+-- ["a"] ?& ["a","a"] == True+-- [["a"]] ?& ["a"] == False+-- ["a","b","c"] ?& ["a","b","d"] == False+-- [9,"false","1",null] ?& ["1","false"] == True+-- [] ?& ["a","b"] == False+-- [{"a":true}] ?& ["a"] == False+-- ["a","b","c","d"] ?& ["b","c","d"] == True+-- [null,4,{"test":false}] ?& [] == True+-- [] ?& [] == True+-- @+--+-- === __Other values__+--+-- This operator functions much like an equivalence operator+-- on strings only. If a string matches with all elements of+-- the given list, the comparison matches.+--+-- @+-- "a" ?& ["a"] == True+-- "1" ?& ["a","1"] == False+-- "b" ?& ["b","b"] == True+-- "ab" ?& ["a","b"] == False+-- 1 ?& ["1"] == False+-- null ?& ["null"] == False+-- true ?& ["true"] == False+-- 31337 ?& [] == True+-- true ?& [] == True+-- null ?& [] == True+-- @+--+-- @since 2.10.0+(?&.) :: EntityField record Value -> [Text] -> Filter record+(?&.) field = jsonFilter " ??& " field . PostgresArray++jsonFilter :: PersistField a => Text -> EntityField record Value -> a -> Filter record+jsonFilter op field a = Filter field (UnsafeValue a) $ BackendSpecificFilter op+++-----------------+-- AESON VALUE --+-----------------+ instance PersistField Value where toPersistValue = toPersistValueJsonB fromPersistValue = fromPersistValueJsonB@@ -161,7 +346,8 @@ Right v -> Right v fromPersistValueJsonB x = Left $ fromPersistValueError "FromJSON" "string or bytea" x --- Constraints on the type are not necessary.+-- Constraints on the type might not be necessary,+-- but better to leave them in. sqlTypeJsonB :: (ToJSON a, FromJSON a) => Proxy a -> SqlType sqlTypeJsonB _ = SqlOther "JSONB" @@ -193,3 +379,10 @@ , " | with error: " , err ]++newtype PostgresArray a = PostgresArray [a]++instance PersistField a => PersistField (PostgresArray a) where+ toPersistValue (PostgresArray ts) = PersistArray $ toPersistValue <$> ts+ fromPersistValue (PersistArray as) = PostgresArray <$> traverse fromPersistValue as+ fromPersistValue wat = Left $ fromPersistValueError "PostgresArray" "array" wat
persistent-postgresql.cabal view
@@ -1,5 +1,5 @@ name: persistent-postgresql-version: 2.9.1+version: 2.10.0 license: MIT license-file: LICENSE author: Felipe Lessa, Michael Snoyman <michael@snoyman.com>@@ -8,33 +8,69 @@ description: Based on the postgresql-simple package category: Database, Yesod stability: Stable-cabal-version: >= 1.6+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: ChangeLog.md library- build-depends: base >= 4.8 && < 5- , transformers >= 0.2.1- , postgresql-simple >= 0.4.0 && < 0.7- , postgresql-libpq >= 0.6.1 && < 0.10- , persistent >= 2.9 && < 3- , containers >= 0.2- , bytestring >= 0.9- , text >= 0.7- , unliftio-core+ build-depends: base >= 4.9 && < 5+ , persistent >= 2.10 && < 3+ , aeson >= 1.0 , blaze-builder- , time >= 1.1- , aeson >= 0.6.2- , conduit >= 1.2.8- , resourcet >= 1.1- , monad-logger >= 0.3.4+ , bytestring >= 0.10+ , conduit >= 1.2.12+ , containers >= 0.5+ , monad-logger >= 0.3.25+ , postgresql-simple >= 0.6.1 && < 0.7+ , postgresql-libpq >= 0.9.4.2 && < 0.10+ , resourcet >= 1.1.9 , resource-pool+ , text >= 1.2+ , time >= 1.6+ , transformers >= 0.5+ , unliftio-core exposed-modules: Database.Persist.Postgresql , Database.Persist.Postgresql.JSON ghc-options: -Wall+ default-language: Haskell2010 source-repository head type: git location: git://github.com/yesodweb/persistent.git++test-suite test+ type: exitcode-stdio-1.0+ main-is: main.hs+ hs-source-dirs: test+ other-modules: PgInit+ ArrayAggTest+ EquivalentTypeTestPostgres+ JSONTest+ ghc-options: -Wall++ build-depends: base >= 4.9 && < 5+ , persistent+ , persistent-postgresql+ , persistent-qq+ , persistent-template+ , persistent-test+ , aeson+ , bytestring+ , containers+ , fast-logger+ , HUnit+ , hspec >= 2.4+ , hspec-expectations+ , monad-logger+ , QuickCheck+ , quickcheck-instances+ , resourcet+ , text+ , time+ , transformers+ , unliftio-core+ , unordered-containers+ , vector+ default-language: Haskell2010
+ test/ArrayAggTest.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} -- FIXME++module ArrayAggTest where++import Control.Monad.IO.Class (MonadIO)+import Data.Aeson+import Data.List (sort)+import qualified Data.Text as T+import Test.Hspec.Expectations ()++import PersistentTestModels+import PgInit++share [mkPersist persistSettings, mkMigrate "jsonTestMigrate"] [persistLowerCase|+ TestValue+ json Value+|]++cleanDB :: (BaseBackend backend ~ SqlBackend, PersistQueryWrite backend, MonadIO m) => ReaderT backend m ()+cleanDB = deleteWhere ([] :: [Filter TestValue])++emptyArr :: Value+emptyArr = toJSON ([] :: [Value])++specs :: RunDb SqlBackend IO -> Spec+specs runDb = do+ describe "rawSql/array_agg" $ do+ let runArrayAggTest :: (PersistField [a], Ord a, Show a) => Text -> [a] -> Assertion+ runArrayAggTest dbField expected = runDb $ 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]" $ do+ runArrayAggTest "ident" ["a", "c", "e", "g" :: Text]+ it "works for [Maybe Text]" $ do+ runArrayAggTest "password" [Nothing, Just "b", Just "d", Just "h" :: Maybe Text]
+ test/EquivalentTypeTestPostgres.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++module EquivalentTypeTestPostgres (specs) where++import Control.Monad.Trans.Resource (runResourceT)+import qualified Data.Text as T++import Database.Persist.TH+import PgInit++share [mkPersist sqlSettings, mkMigrate "migrateAll1"] [persistLowerCase|+EquivalentType sql=equivalent_types+ field1 Int+ field2 T.Text sqltype=text+ field3 T.Text sqltype=us_postal_code+ deriving Eq Show+|]++share [mkPersist sqlSettings, mkMigrate "migrateAll2"] [persistLowerCase|+EquivalentType2 sql=equivalent_types+ field1 Int+ field2 T.Text+ field3 T.Text sqltype=us_postal_code+ deriving Eq Show+|]++specs :: Spec+specs = describe "doesn't migrate equivalent types" $ do+ it "works" $ asIO $ runResourceT $ runConn $ do++ _ <- rawExecute "DROP DOMAIN IF EXISTS us_postal_code CASCADE" []+ _ <- rawExecute "CREATE DOMAIN us_postal_code AS TEXT CHECK(VALUE ~ '^\\d{5}$')" []++ _ <- runMigrationSilent migrateAll1+ xs <- getMigration migrateAll2+ liftIO $ xs @?= []
+ test/JSONTest.hs view
@@ -0,0 +1,467 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} -- FIXME++module JSONTest where++import Control.Monad.IO.Class (MonadIO)+import Data.Aeson+import qualified Data.Vector as V (fromList)+import Test.HUnit (assertBool)+import Test.Hspec.Expectations ()++import Database.Persist+import Database.Persist.Postgresql.JSON++import PgInit++share [mkPersist persistSettings, mkMigrate "jsonTestMigrate"] [persistLowerCase|+ TestValue+ json Value+ deriving Show+|]++cleanDB :: (BaseBackend backend ~ SqlBackend, PersistQueryWrite backend, MonadIO m) => ReaderT backend m ()+cleanDB = deleteWhere ([] :: [Filter TestValue])++emptyArr :: Value+emptyArr = toJSON ([] :: [Value])++insert' :: (MonadIO m, PersistStoreWrite backend, BaseBackend backend ~ SqlBackend)+ => Value -> ReaderT backend m (Key TestValue)+insert' = insert . TestValue++(=@=) :: MonadIO m => String -> Bool -> m ()+s =@= b = liftIO $ assertBool s b++matchKeys :: (Show record, Show (Key record), MonadIO m, Eq (Key record))+ => String -> [Key record] -> [Entity record] -> m ()+matchKeys s ys xs = do+ msg1 =@= (xLen == yLen)+ forM_ ys $ \y -> msg2 y =@= (y `elem` ks)+ where ks = entityKey <$> xs+ xLen = length xs+ yLen = length ys+ msg1 = mconcat+ [ s, "\nexpected: ", show yLen+ , "\n but got: ", show xLen+ , "\n[xs: ", show xs+ , ", ys: ", show ys, "]"+ ]+ msg2 y = mconcat+ [ s, ": "+ , "key \"", show y+ , "\" not in result:\n ", show ks+ ]++specs :: Spec+specs = describe "postgresql's JSON operators behave" $ do++ it "migrate, clean table, insert values and check queries" $ asIO $ runConn $ do+ runMigration jsonTestMigrate+ cleanDB++ liftIO $ putStrLn "\n- - - - - Inserting JSON values - - - - -\n"++ nullK <- insert' Null++ boolTK <- insert' $ Bool True+ boolFK <- insert' $ toJSON False++ num0K <- insert' $ Number 0+ num1K <- insert' $ Number 1+ numBigK <- insert' $ toJSON (1234567890 :: Int)+ numFloatK <- insert' $ Number 0.0+ numSmallK <- insert' $ Number 0.0000000000000000123+ numFloat2K <- insert' $ Number 1.5+ -- numBigFloatK will turn into 9876543210.123457 because JSON+ numBigFloatK <- insert' $ toJSON (9876543210.123456789 :: Double)++ strNullK <- insert' $ String ""+ strObjK <- insert' $ String "{}"+ strArrK <- insert' $ String "[]"+ strAK <- insert' $ String "a"+ strTestK <- insert' $ toJSON ("testing" :: Text)+ str2K <- insert' $ String "2"+ strFloatK <- insert' $ String "0.45876"++ arrNullK <- insert' $ Array $ V.fromList []+ arrListK <- insert' $ toJSON ([emptyArr,emptyArr,toJSON [emptyArr,emptyArr]])+ arrList2K <- insert' $ toJSON [emptyArr,toJSON [Number 3,Bool False],toJSON [emptyArr,toJSON [Object mempty]]]+ arrFilledK <- insert' $ toJSON [Null, Number 4, String "b", Object mempty, emptyArr, object [ "test" .= [Null], "test2" .= String "yes"]]++ objNullK <- insert' $ Object mempty+ objTestK <- insert' $ object ["test" .= Null, "test1" .= String "no"]+ objDeepK <- insert' $ object ["c" .= Number 24.986, "foo" .= object ["deep1" .= Bool True]]++----------------------------------------------------------------------------------------++ liftIO $ putStrLn "\n- - - - - Starting @> tests - - - - -\n"++ -- An empty Object matches any object+ selectList [TestValueJson @>. Object mempty] []+ >>= matchKeys "1" [objNullK,objTestK,objDeepK]++ -- {"test":null,"test1":"no"} @> {"test":null} == True+ selectList [TestValueJson @>. object ["test" .= Null]] []+ >>= matchKeys "2" [objTestK]++ -- {"c":24.986,"foo":{"deep1":true"}} @> {"foo":{}} == True+ selectList [TestValueJson @>. object ["foo" .= object []]] []+ >>= matchKeys "3" [objDeepK]++ -- {"c":24.986,"foo":{"deep1":true"}} @> {"foo":"nope"} == False+ selectList [TestValueJson @>. object ["foo" .= String "nope"]] []+ >>= matchKeys "4" []++ -- {"c":24.986,"foo":{"deep1":true"}} @> {"foo":{"deep1":true}} == True+ selectList [TestValueJson @>. (object ["foo" .= object ["deep1" .= True]])] []+ >>= matchKeys "5" [objDeepK]++ -- {"c":24.986,"foo":{"deep1":true"}} @> {"deep1":true} == False+ selectList [TestValueJson @>. object ["deep1" .= True]] []+ >>= matchKeys "6" []++ -- An empty Array matches any array+ selectList [TestValueJson @>. emptyArr] []+ >>= matchKeys "7" [arrNullK,arrListK,arrList2K,arrFilledK]++ -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @> [4] == True+ selectList [TestValueJson @>. toJSON [4 :: Int]] []+ >>= matchKeys "8" [arrFilledK]++ -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @> [null,"b"] == True+ selectList [TestValueJson @>. toJSON [Null, String "b"]] []+ >>= matchKeys "9" [arrFilledK]++ -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @> [null,"d"] == False+ selectList [TestValueJson @>. toJSON [emptyArr, String "d"]] []+ >>= matchKeys "10" []++ -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @> [[],"b",{"test":[null],"test2":"yes"},4,null,{}] == True+ selectList [TestValueJson @>. toJSON [emptyArr, String "b", object [ "test" .= [Null], "test2" .= String "yes"], Number 4, Null, Object mempty]] []+ >>= matchKeys "11" [arrFilledK]++ -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @> [null,4,"b",{},[],{"test":[null],"test2":"yes"},false] == False+ selectList [TestValueJson @>. toJSON [Null, Number 4, String "b", Object mempty, emptyArr, object [ "test" .= [Null], "test2" .= String "yes"], Bool False]] []+ >>= matchKeys "12" []++ -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @> [{}] == True+ selectList [TestValueJson @>. toJSON [Object mempty]] []+ >>= matchKeys "13" [arrFilledK]++ -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @> [{"test":[]}] == True+ selectList [TestValueJson @>. toJSON [object ["test" .= emptyArr]]] []+ >>= matchKeys "14" [arrFilledK]++ -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @> [{"test1":[null]}] == False+ selectList [TestValueJson @>. toJSON [object ["test1" .= [Null]]]] []+ >>= matchKeys "15" []++ -- [[],[],[[],[]]] @> [[]] == True+ -- [[],[3,false],[[],[{}]]] @> [[]] == True+ -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @> [[]] == True+ selectList [TestValueJson @>. toJSON [emptyArr]] []+ >>= matchKeys "16" [arrListK,arrList2K,arrFilledK]++ -- [[],[3,false],[[],[{}]]] @> [[3]] == True+ selectList [TestValueJson @>. toJSON [[3 :: Int]]] []+ >>= matchKeys "17" [arrList2K]++ -- [[],[3,false],[[],[{}]]] @> [[true,3]] == False+ selectList [TestValueJson @>. toJSON [[Bool True, Number 3]]] []+ >>= matchKeys "18" []++ -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @> 4 == True+ selectList [TestValueJson @>. Number 4] []+ >>= matchKeys "19" [arrFilledK]++ -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @> 4 == True+ selectList [TestValueJson @>. Number 99] []+ >>= matchKeys "20" []++ -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @> "b" == True+ selectList [TestValueJson @>. String "b"] []+ >>= matchKeys "21" [arrFilledK]++ -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @> "{}" == False+ selectList [TestValueJson @>. String "{}"] []+ >>= matchKeys "22" [strObjK]++ -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @> {"test":[null],"test2":"yes"} == False+ selectList [TestValueJson @>. object [ "test" .= [Null], "test2" .= String "yes"]] []+ >>= matchKeys "23" []++ -- "testing" @> "testing" == True+ selectList [TestValueJson @>. String "testing"] []+ >>= matchKeys "24" [strTestK]++ -- "testing" @> "Testing" == False+ selectList [TestValueJson @>. String "Testing"] []+ >>= matchKeys "25" []++ -- "testing" @> "test" == False+ selectList [TestValueJson @>. String "test"] []+ >>= matchKeys "26" []++ -- "testing" @> {"testing":1} == False+ selectList [TestValueJson @>. object ["testing" .= Number 1]] []+ >>= matchKeys "27" []++ -- 1 @> 1 == True+ selectList [TestValueJson @>. toJSON (1 :: Int)] []+ >>= matchKeys "28" [num1K]++ -- 0 @> 0.0 == True+ -- 0.0 @> 0.0 == True+ selectList [TestValueJson @>. toJSON (0.0 :: Double)] []+ >>= matchKeys "29" [num0K,numFloatK]++ -- 1234567890 @> 123456789 == False+ selectList [TestValueJson @>. toJSON (123456789 :: Int)] []+ >>= matchKeys "30" []++ -- 1234567890 @> 234567890 == False+ selectList [TestValueJson @>. toJSON (234567890 :: Int)] []+ >>= matchKeys "31" []++ -- 1 @> "1" == False+ selectList [TestValueJson @>. String "1"] []+ >>= matchKeys "32" []++ -- 1234567890 @> [1,2,3,4,5,6,7,8,9,0] == False+ selectList [TestValueJson @>. toJSON ([1,2,3,4,5,6,7,8,9,0] :: [Int])] []+ >>= matchKeys "33" []++ -- true @> true == True+ -- false @> true == False+ selectList [TestValueJson @>. toJSON True] []+ >>= matchKeys "34" [boolTK]++ -- false @> false == True+ -- true @> false == False+ selectList [TestValueJson @>. Bool False] []+ >>= matchKeys "35" [boolFK]++ -- true @> "true" == False+ selectList [TestValueJson @>. String "true"] []+ >>= matchKeys "36" []++ -- null @> null == True+ selectList [TestValueJson @>. Null] []+ >>= matchKeys "37" [nullK,arrFilledK]++ -- null @> "null" == False+ selectList [TestValueJson @>. String "null"] []+ >>= matchKeys "38" []++----------------------------------------------------------------------------------------++ liftIO $ putStrLn "\n- - - - - Starting <@ tests - - - - -\n"++ -- {} <@ {"test":null,"test1":"no","blabla":[]} == True+ -- {"test":null,"test1":"no"} <@ {"test":null,"test1":"no","blabla":[]} == True+ selectList [TestValueJson <@. object ["test" .= Null, "test1" .= String "no", "blabla" .= emptyArr]] []+ >>= matchKeys "39" [objNullK,objTestK]++ -- [] <@ [null,4,"b",{},[],{"test":[null],"test2":"yes"},false] == True+ -- null <@ [null,4,"b",{},[],{"test":[null],"test2":"yes"},false] == True+ -- false <@ [null,4,"b",{},[],{"test":[null],"test2":"yes"},false] == True+ -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] <@ [null,4,"b",{},[],{"test":[null],"test2":"yes"},false] == True+ selectList [TestValueJson <@. toJSON [Null, Number 4, String "b", Object mempty, emptyArr, object [ "test" .= [Null], "test2" .= String "yes"], Bool False]] []+ >>= matchKeys "40" [arrNullK,arrFilledK,boolFK,nullK]++ -- "a" <@ "a" == True+ selectList [TestValueJson <@. String "a"] []+ >>= matchKeys "41" [strAK]+++ -- 9876543210.123457 <@ 9876543210.123457 == False+ selectList [TestValueJson <@. Number 9876543210.123457] []+ >>= matchKeys "42" [numBigFloatK]++ -- 9876543210.123457 <@ 9876543210.123456789 == False+ selectList [TestValueJson <@. Number 9876543210.123456789] []+ >>= matchKeys "43" []++ -- null <@ null == True+ selectList [TestValueJson <@. Null] []+ >>= matchKeys "44" [nullK]++----------------------------------------------------------------------------------------++ liftIO $ putStrLn "\n- - - - - Starting ? tests - - - - -\n"++ arrList3K <- insert' $ toJSON [toJSON [String "a"], Number 1]+ arrList4K <- insert' $ toJSON [String "a", String "b", String "c", String "d"]+ objEmptyK <- insert' $ object ["" .= Number 9001]+ objFullK <- insert' $ object ["a" .= Number 1, "b" .= Number 2, "c" .= Number 3, "d" .= Number 4]++ -- {"test":null,"test1":"no"} ? "test" == True+ -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] ? "test" == False+ selectList [TestValueJson ?. "test"] []+ >>= matchKeys "45" [objTestK]++ -- {"c":24.986,"foo":{"deep1":true"}} ? "deep1" == False+ selectList [TestValueJson ?. "deep1"] []+ >>= matchKeys "46" []++ -- "{}" ? "{}" == True+ -- {} ? "{}" == False+ selectList [TestValueJson ?. "{}"] []+ >>= matchKeys "47" [strObjK]++ -- {} ? "" == False+ -- "" ? "" == True+ -- {"":9001} ? "" == True+ selectList [TestValueJson ?. ""] []+ >>= matchKeys "48" [strNullK,objEmptyK]++ -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] ? "b" == True+ selectList [TestValueJson ?. "b"] []+ >>= matchKeys "49" [arrFilledK,arrList4K,objFullK]++ -- [["a"]] ? "a" == False+ -- "a" ? "a" == True+ -- ["a","b","c","d"] ? "a" == True+ -- {"a":1,"b":2,"c":3,"d":4} ? "a" == True+ selectList [TestValueJson ?. "a"] []+ >>= matchKeys "50" [strAK,arrList4K,objFullK]++ -- "[]" ? "[]" == True+ -- [] ? "[]" == False+ selectList [TestValueJson ?. "[]"] []+ >>= matchKeys "51" [strArrK]++ -- null ? "null" == False+ selectList [TestValueJson ?. "null"] []+ >>= matchKeys "52" []++ -- true ? "true" == False+ selectList [TestValueJson ?. "true"] []+ >>= matchKeys "53" []++----------------------------------------------------------------------------------------++ liftIO $ putStrLn "\n- - - - - Starting ?| tests - - - - -\n"++ -- "a" ?| ["a","b","c"] == True+ -- [["a"],1] ?| ["a","b","c"] == False+ -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] ?| ["a","b","c"] == True+ -- ["a","b","c","d"] ?| ["a","b","c"] == True+ -- {"a":1,"b":2,"c":3,"d":4} ?| ["a","b","c"] == True+ selectList [TestValueJson ?|. ["a","b","c"]] []+ >>= matchKeys "54" [strAK,arrFilledK,objDeepK,arrList4K,objFullK]++ -- "{}" ?| ["{}"] == True+ -- {} ?| ["{}"] == False+ selectList [TestValueJson ?|. ["{}"]] []+ >>= matchKeys "55" [strObjK]++ -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] ?| ["test"] == False+ -- "testing" ?| ["test"] == False+ -- {"test":null,"test1":"no"} ?| ["test"] == True+ selectList [TestValueJson ?|. ["test"]] []+ >>= matchKeys "56" [objTestK]++ -- {"c":24.986,"foo":{"deep1":true"}} ?| ["deep1"] == False+ selectList [TestValueJson ?|. ["deep1"]] []+ >>= matchKeys "57" []++ -- ANYTHING ?| [] == False+ selectList [TestValueJson ?|. []] []+ >>= matchKeys "58" []++ -- true ?| ["true","null","1"] == False+ -- null ?| ["true","null","1"] == False+ -- 1 ?| ["true","null","1"] == False+ selectList [TestValueJson ?|. ["true","null","1"]] []+ >>= matchKeys "59" []++ -- [] ?| ["[]"] == False+ -- "[]" ?| ["[]"] == True+ selectList [TestValueJson ?|. ["[]"]] []+ >>= matchKeys "60" [strArrK]++----------------------------------------------------------------------------------------++ liftIO $ putStrLn "\n- - - - - Starting ?& tests - - - - -\n"++ -- ANYTHING ?& [] == True+ selectList [TestValueJson ?&. []] []+ >>= matchKeys "61" [ nullK+ , boolTK, boolFK+ , num0K, num1K, numBigK, numFloatK, numSmallK, numFloat2K, numBigFloatK+ , strNullK, strObjK, strArrK, strAK, strTestK, str2K, strFloatK+ , arrNullK, arrListK, arrList2K, arrFilledK+ , objNullK, objTestK, objDeepK++ , arrList3K, arrList4K+ , objEmptyK, objFullK+ ]++ -- "a" ?& ["a"] == True+ -- [["a"],1] ?& ["a"] == False+ -- ["a","b","c","d"] ?& ["a"] == True+ -- {"a":1,"b":2,"c":3,"d":4} ?& ["a"] == True+ selectList [TestValueJson ?&. ["a"]] []+ >>= matchKeys "62" [strAK,arrList4K,objFullK]++ -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] ?& ["b","c"] == False+ -- {"c":24.986,"foo":{"deep1":true"}} ?& ["b","c"] == False+ -- ["a","b","c","d"] ?& ["b","c"] == True+ -- {"a":1,"b":2,"c":3,"d":4} ?& ["b","c"] == True+ selectList [TestValueJson ?&. ["b","c"]] []+ >>= matchKeys "63" [arrList4K,objFullK]++ -- {} ?& ["{}"] == False+ -- "{}" ?& ["{}"] == True+ selectList [TestValueJson ?&. ["{}"]] []+ >>= matchKeys "64" [strObjK]++ -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] ?& ["test"] == False+ -- "testing" ?& ["test"] == False+ -- {"test":null,"test1":"no"} ?& ["test"] == True+ selectList [TestValueJson ?&. ["test"]] []+ >>= matchKeys "65" [objTestK]++ -- {"c":24.986,"foo":{"deep1":true"}} ?& ["deep1"] == False+ selectList [TestValueJson ?&. ["deep1"]] []+ >>= matchKeys "66" []++ -- "a" ?& ["a","e"] == False+ -- ["a","b","c","d"] ?& ["a","e"] == False+ -- {"a":1,"b":2,"c":3,"d":4} ?& ["a","e"] == False+ selectList [TestValueJson ?&. ["a","e"]] []+ >>= matchKeys "67" []++ -- [] ?& ["[]"] == False+ -- "[]" ?& ["[]"] == True+ selectList [TestValueJson ?&. ["[]"]] []+ >>= matchKeys "68" [strArrK]++ -- THIS WILL FAIL IF THE IMPLEMENTATION USES+ -- @ '{null}' @+ -- INSTEAD OF+ -- @ ARRAY['null'] @+ -- null ?& ["null"] == False+ selectList [TestValueJson ?&. ["null"]] []+ >>= matchKeys "69" []++ -- [["a"],1] ?& ["1"] == False+ -- "1" ?& ["1"] == True+ selectList [TestValueJson ?&. ["1"]] []+ >>= matchKeys "70" []++ -- {} ?& [""] == False+ -- [] ?& [""] == False+ -- "" ?& [""] == True+ -- {"":9001} ?& [""] == True+ selectList [TestValueJson ?&. [""]] []+ >>= matchKeys "71" [strNullK,objEmptyK]
+ test/PgInit.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module PgInit (+ runConn++ , MonadIO+ , persistSettings+ , MkPersistSettings (..)+ , db+ , BackendKey(..)+ , GenerateKey(..)++ -- re-exports+ , module Control.Monad.Trans.Reader+ , module Control.Monad+ , module Database.Persist.Sql+ , module Database.Persist+ , module Database.Persist.Sql.Raw.QQ+ , module Init+ , module Test.Hspec+ , module Test.HUnit+ , BS.ByteString+ , Int32, Int64+ , liftIO+ , mkPersist, mkMigrate, share, sqlSettings, persistLowerCase, persistUpperCase+ , SomeException+ , Text+ , TestFn(..)+ ) where++import Init+ ( TestFn(..), truncateTimeOfDay, truncateUTCTime+ , truncateToMicro, arbText, liftA2, GenerateKey(..)+ , (@/=), (@==), (==@), MonadFail+ , assertNotEqual, assertNotEmpty, assertEmpty, asIO+ , isTravis, RunDb+ )++-- re-exports+import Control.Exception (SomeException)+import Control.Monad (void, replicateM, liftM, when, forM_)+import Control.Monad.Trans.Reader+import Data.Aeson (Value(..))+import Database.Persist.TH (mkPersist, mkMigrate, share, sqlSettings, persistLowerCase, persistUpperCase, MkPersistSettings(..))+import Database.Persist.Sql.Raw.QQ+import Database.Persist.Postgresql.JSON()+import Test.Hspec+import Test.QuickCheck.Instances ()++-- testing+import Test.HUnit ((@?=),(@=?), Assertion, assertFailure, assertBool)+import Test.QuickCheck++import Control.Monad (unless, (>=>))+import Control.Monad.IO.Class+import Control.Monad.IO.Unlift (MonadUnliftIO)+import Control.Monad.Logger+import Control.Monad.Trans.Resource (ResourceT, runResourceT)+import qualified Data.ByteString as BS+import qualified Data.HashMap.Strict as HM+import Data.Int (Int32, Int64)+import Data.Maybe (fromMaybe)+import Data.Monoid ((<>))+import Data.Text (Text)+import System.Environment (getEnvironment)+import System.Log.FastLogger (fromLogStr)++import Database.Persist+import Database.Persist.Postgresql+import Database.Persist.Sql+import Database.Persist.TH ()++_debugOn :: Bool+_debugOn = False++dockerPg :: IO (Maybe BS.ByteString)+dockerPg = do+ env <- liftIO getEnvironment+ return $ case lookup "POSTGRES_NAME" env of+ Just _name -> Just "postgres" -- /persistent/postgres+ _ -> Nothing++persistSettings :: MkPersistSettings+persistSettings = sqlSettings { mpsGeneric = True }++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+ _ <- if travis+ then withPostgresqlPool "host=localhost port=5432 user=postgres dbname=persistent" 1 $ runSqlPool f+ else do+ host <- fromMaybe "localhost" <$> liftIO dockerPg+ withPostgresqlPool ("host=" <> host <> " port=5432 user=postgres dbname=test") 1 $ runSqlPool f+ return ()++db :: SqlPersistT (LoggingT (ResourceT IO)) () -> Assertion+db actions = do+ runResourceT $ runConn $ actions >> transactionUndo++instance Arbitrary Value where+ arbitrary = frequency [ (1, pure Null)+ , (1, Bool <$> arbitrary)+ , (2, Number <$> arbitrary)+ , (2, String <$> arbText)+ , (3, Array <$> limitIt 4 arbitrary)+ , (3, Object <$> arbObject)+ ]+ where limitIt i x = sized $ \n -> do+ let m = if n > i then i else n+ resize m x+ arbObject = limitIt 4 -- Recursion can make execution divergent+ $ fmap HM.fromList -- HashMap -> [(,)]+ . listOf -- [(,)] -> (,)+ . liftA2 (,) arbText -- (,) -> Text and Value+ $ limitIt 4 arbitrary -- Again, precaution against divergent recursion.
+ test/main.hs view
@@ -0,0 +1,176 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++import PgInit++import Data.Aeson+import qualified Data.ByteString as BS+import Data.IntMap (IntMap)+import Data.Fixed+import qualified Data.Text as T+import Data.Time+import Test.QuickCheck++-- FIXME: should probably be used?+-- import qualified ArrayAggTest+import qualified CompositeTest+import qualified CustomPersistFieldTest+import qualified CustomPrimaryKeyReferenceTest+import qualified DataTypeTest+import qualified EmbedOrderTest+import qualified EmbedTest+import qualified EmptyEntityTest+import qualified EquivalentTypeTestPostgres+import qualified HtmlTest+import qualified JSONTest+import qualified LargeNumberTest+import qualified MaxLenTest+import qualified MigrationColumnLengthTest+import qualified MigrationOnlyTest+import qualified MpsNoPrefixTest+import qualified PersistentTest+import qualified PersistUniqueTest+import qualified PrimaryTest+import qualified RawSqlTest+import qualified ReadWriteTest+import qualified Recursive+import qualified RenameTest+import qualified SumTypeTest+import qualified TransactionLevelTest+import qualified TreeTest+import qualified UniqueTest+import qualified UpsertTest++type Tuple = (,)++-- Test lower case names+share [mkPersist persistSettings, mkMigrate "dataTypeMigrate"] [persistLowerCase|+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+ pico Pico+ time TimeOfDay+ utc UTCTime+ jsonb Value+|]++instance Arbitrary DataTypeTable where+ arbitrary = DataTypeTable+ <$> arbText -- text+ <*> (T.take 100 <$> arbText) -- textManLen+ <*> arbitrary -- bytes+ <*> liftA2 (,) arbitrary arbText -- bytesTextTuple+ <*> (BS.take 100 <$> arbitrary) -- bytesMaxLen+ <*> arbitrary -- int+ <*> arbitrary -- intList+ <*> arbitrary -- intMap+ <*> arbitrary -- double+ <*> arbitrary -- bool+ <*> arbitrary -- day+ <*> arbitrary -- pico+ <*> (arbitrary) -- utc+ <*> (truncateUTCTime =<< arbitrary) -- utc+ <*> arbitrary -- value++setup :: MonadIO m => Migration -> ReaderT SqlBackend m ()+setup migration = do+ printMigration migration+ runMigrationUnsafe migration++main :: IO ()+main = do+ runConn $ do+ mapM_ setup+ [ PersistentTest.testMigrate+ , PersistentTest.noPrefixMigrate+ , EmbedTest.embedMigrate+ , EmbedOrderTest.embedOrderMigrate+ , LargeNumberTest.numberMigrate+ , UniqueTest.uniqueMigrate+ , MaxLenTest.maxlenMigrate+ , Recursive.recursiveMigrate+ , CompositeTest.compositeMigrate+ , TreeTest.treeMigrate+ , PersistUniqueTest.migration+ , RenameTest.migration+ , CustomPersistFieldTest.customFieldMigrate+ , PrimaryTest.migration+ , CustomPrimaryKeyReferenceTest.migration+ , MigrationColumnLengthTest.migration+ , TransactionLevelTest.migration+ ]+ PersistentTest.cleanDB++ hspec $ do+ RenameTest.specsWith db+ DataTypeTest.specsWith db+ (Just (runMigrationSilent dataTypeMigrate))+ [ TestFn "text" dataTypeTableText+ , TestFn "textMaxLen" dataTypeTableTextMaxLen+ , TestFn "bytes" dataTypeTableBytes+ , TestFn "bytesTextTuple" dataTypeTableBytesTextTuple+ , TestFn "bytesMaxLen" dataTypeTableBytesMaxLen+ , TestFn "int" dataTypeTableInt+ , TestFn "intList" dataTypeTableIntList+ , TestFn "intMap" dataTypeTableIntMap+ , TestFn "bool" dataTypeTableBool+ , TestFn "day" dataTypeTableDay+ , TestFn "time" (DataTypeTest.roundTime . dataTypeTableTime)+ , TestFn "utc" (DataTypeTest.roundUTCTime . dataTypeTableUtc)+ , TestFn "jsonb" dataTypeTableJsonb+ ]+ [ ("pico", dataTypeTablePico) ]+ dataTypeTableDouble+ HtmlTest.specsWith+ db+ (Just (runMigrationSilent HtmlTest.htmlMigrate))+ EmbedTest.specsWith db+ EmbedOrderTest.specsWith db+ LargeNumberTest.specsWith db+ UniqueTest.specsWith db+ MaxLenTest.specsWith db+ Recursive.specsWith db+ SumTypeTest.specsWith db (Just (runMigrationSilent SumTypeTest.sumTypeMigrate))+ MigrationOnlyTest.specsWith db+ (Just+ $ runMigrationSilent MigrationOnlyTest.migrateAll1+ >> runMigrationSilent MigrationOnlyTest.migrateAll2+ )+ PersistentTest.specsWith db+ ReadWriteTest.specsWith db+ PersistentTest.filterOrSpecs db+ RawSqlTest.specsWith db+ UpsertTest.specsWith+ db+ UpsertTest.Don'tUpdateNull+ UpsertTest.UpsertPreserveOldKey++ MpsNoPrefixTest.specsWith db+ EmptyEntityTest.specsWith db (Just (runMigrationSilent EmptyEntityTest.migration))+ CompositeTest.specsWith db+ TreeTest.specsWith db+ PersistUniqueTest.specsWith db+ PrimaryTest.specsWith db+ CustomPersistFieldTest.specsWith db+ CustomPrimaryKeyReferenceTest.specsWith db+ MigrationColumnLengthTest.specsWith db+ EquivalentTypeTestPostgres.specs+ TransactionLevelTest.specsWith db+ JSONTest.specs+ -- FIXME: not used, probably should?+ -- ArrayAggTest.specs db