diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/Database/Persist/Postgresql.hs b/Database/Persist/Postgresql.hs --- a/Database/Persist/Postgresql.hs +++ b/Database/Persist/Postgresql.hs @@ -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) diff --git a/Database/Persist/Postgresql/JSON.hs b/Database/Persist/Postgresql/JSON.hs --- a/Database/Persist/Postgresql/JSON.hs +++ b/Database/Persist/Postgresql/JSON.hs @@ -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 diff --git a/persistent-postgresql.cabal b/persistent-postgresql.cabal --- a/persistent-postgresql.cabal +++ b/persistent-postgresql.cabal @@ -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 @@ -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 diff --git a/test/ArrayAggTest.hs b/test/ArrayAggTest.hs new file mode 100644 --- /dev/null +++ b/test/ArrayAggTest.hs @@ -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] diff --git a/test/EquivalentTypeTestPostgres.hs b/test/EquivalentTypeTestPostgres.hs new file mode 100644 --- /dev/null +++ b/test/EquivalentTypeTestPostgres.hs @@ -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 @?= [] diff --git a/test/JSONTest.hs b/test/JSONTest.hs new file mode 100644 --- /dev/null +++ b/test/JSONTest.hs @@ -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] diff --git a/test/PgInit.hs b/test/PgInit.hs new file mode 100644 --- /dev/null +++ b/test/PgInit.hs @@ -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. diff --git a/test/main.hs b/test/main.hs new file mode 100644 --- /dev/null +++ b/test/main.hs @@ -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