diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,10 @@ +## 2.8.2 + +Added module `Database.Persist.Postgres.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 + ## 2.8.1.1 * Added a more detailed error message when a `numeric` column's scale and precision can't be parsed. [#781](https://github.com/yesodweb/persistent/pull/781) diff --git a/Database/Persist/Postgresql.hs b/Database/Persist/Postgresql.hs --- a/Database/Persist/Postgresql.hs +++ b/Database/Persist/Postgresql.hs @@ -88,7 +88,7 @@ -- string would be @\"host=localhost port=5432 user=test -- dbname=test password=test\"@. Please read libpq's -- documentation at --- +-- -- for more details on how to create such strings. type ConnectionString = ByteString @@ -104,8 +104,8 @@ -- | Create a PostgreSQL connection pool and run the given -- action. The pool is properly released after the action -- finishes using it. Note that you should not use the given --- 'ConnectionPool' outside the action since it may be already --- been released. +-- 'ConnectionPool' outside the action since it may already +-- have been released. withPostgresqlPool :: (MonadLogger m, MonadUnliftIO m, IsSqlBackend backend) => ConnectionString -- ^ Connection string to the database. @@ -119,12 +119,12 @@ withPostgresqlPool ci = withPostgresqlPoolWithVersion getServerVersion ci -- | Same as 'withPostgresPool', but takes a callback for obtaining --- the server version (to workaround an Amazon Redshift bug). +-- the server version (to work around an Amazon Redshift bug). -- -- @since 2.6.2 withPostgresqlPoolWithVersion :: (MonadUnliftIO m, MonadLogger m, IsSqlBackend backend) => (PG.Connection -> IO (Maybe Double)) - -- ^ action to perform to get the server version + -- ^ Action to perform to get the server version. -> ConnectionString -- ^ Connection string to the database. -> Int @@ -159,21 +159,21 @@ -- @since 2.1.3 createPostgresqlPoolModified :: (MonadUnliftIO m, MonadLogger m, IsSqlBackend backend) - => (PG.Connection -> IO ()) -- ^ action to perform after connection is created + => (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) createPostgresqlPoolModified = createPostgresqlPoolModifiedWithVersion getServerVersion -- | Same as other similarly-named functions in this module, but takes callbacks for obtaining --- the server version (to workaround an Amazon Redshift bug) and connection-specific tweaking +-- the server version (to work around an Amazon Redshift bug) and connection-specific tweaking -- (to change the schema). -- -- @since 2.6.2 createPostgresqlPoolModifiedWithVersion :: (MonadUnliftIO m, MonadLogger m, IsSqlBackend backend) - => (PG.Connection -> IO (Maybe Double)) -- ^ action to perform to get the server version - -> (PG.Connection -> IO ()) -- ^ action to perform after connection is created + => (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) @@ -187,7 +187,7 @@ withPostgresqlConn = withPostgresqlConnWithVersion getServerVersion -- | Same as 'withPostgresqlConn', but takes a callback for obtaining --- the server version (to workaround an Amazon Redshift bug). +-- the server version (to work around an Amazon Redshift bug). -- -- @since 2.6.2 withPostgresqlConnWithVersion :: (MonadUnliftIO m, MonadLogger m, IsSqlBackend backend) @@ -232,7 +232,7 @@ else Nothing --- | Generate a 'SqlBackend' from a 'PG.Connection' +-- | Generate a 'SqlBackend' from a 'PG.Connection'. openSimpleConn :: (IsSqlBackend backend) => LogFunc -> PG.Connection -> IO backend openSimpleConn logFunc conn = do smap <- newIORef $ Map.empty @@ -240,7 +240,7 @@ return $ createBackend logFunc serverVersion smap conn -- | Create the backend given a logging function, server version, mutable statement cell, --- and connection +-- and connection. createBackend :: IsSqlBackend backend => LogFunc -> Maybe Double -> IORef (Map.Map Text Statement) -> PG.Connection -> backend createBackend logFunc serverVersion smap conn = do @@ -1053,13 +1053,13 @@ , escape cname ] --- | get the SQL string for the table that a PeristEntity represents --- Useful for raw SQL queries +-- | Get the SQL string for the table that a PeristEntity represents. +-- Useful for raw SQL queries. tableName :: (PersistEntity record) => record -> Text tableName = escape . tableDBName --- | get the SQL string for the field that an EntityField represents --- Useful for raw SQL queries +-- | Get the SQL string for the field that an EntityField represents. +-- Useful for raw SQL queries. fieldName :: (PersistEntity record) => EntityField record typ -> Text fieldName = escape . fieldDBName @@ -1078,7 +1078,7 @@ { pgConnStr :: ConnectionString -- ^ The connection string. , pgPoolSize :: Int - -- ^ How many connections should be held on the connection pool. + -- ^ How many connections should be held in the connection pool. } deriving (Show, Read, Data, Typeable) instance FromJSON PostgresConf where @@ -1180,7 +1180,7 @@ -- | Mock a migration even when the database is not present. -- This function performs the same functionality of 'printMigration' --- with the difference that an actualy database isn't needed for it. +-- with the difference that an actual database is not needed. mockMigration :: Migration -> IO () mockMigration mig = do smap <- newIORef $ Map.empty @@ -1238,7 +1238,7 @@ , commaSeparated fieldSets ] --- | Enable a Postgres extension. See https://www.postgresql.org/docs/10/static/contrib.html +-- | Enable a Postgres extension. See https://www.postgresql.org/docs/current/static/contrib.html -- for a list. migrateEnableExtension :: Text -> Migration migrateEnableExtension extName = WriterT $ WriterT $ do diff --git a/Database/Persist/Postgresql/JSON.hs b/Database/Persist/Postgresql/JSON.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/Postgresql/JSON.hs @@ -0,0 +1,195 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | 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.Encoding as TE (encodeUtf8) + +import Database.Persist (EntityField, Filter(..), PersistValue(..), PersistField(..), PersistFilter(..)) +import Database.Persist.Sql (PersistFieldSql(..), SqlType(..)) + + +infix 4 @>., <@. + +-- | This operator checks inclusion of the JSON value +-- on the right hand side in the JSON value on the left +-- hand side. +-- +-- === __Objects__ +-- +-- An empty Object matches any object +-- +-- @ +-- {} \@> {} == True +-- {"a":1,"b":false} \@> {} == True +-- @ +-- +-- Any key-value will be matched top-level +-- +-- @ +-- {"a":1,"b":{"c":true"}} \@> {"a":1} == True +-- {"a":1,"b":{"c":true"}} \@> {"b":1} == False +-- {"a":1,"b":{"c":true"}} \@> {"b":{}} == True +-- {"a":1,"b":{"c":true"}} \@> {"c":true} == False +-- {"a":1,"b":{"c":true"}} \@> {"b":{c":true}} == True +-- @ +-- +-- === __Arrays__ +-- +-- An empty Array matches any array +-- +-- @ +-- [] \@> [] == True +-- [1,2,"hi",false,null] \@> [] == True +-- @ +-- +-- Any array has to be a sub-set. +-- Any object or array will also be compared as being a subset of. +-- +-- @ +-- [1,2,"hi",false,null] \@> [1] == True +-- [1,2,"hi",false,null] \@> [null,"hi"] == True +-- [1,2,"hi",false,null] \@> ["hi",true] == False +-- [1,2,"hi",false,null] \@> ["hi",2,null,false,1] == True +-- [1,2,"hi",false,null] \@> [1,2,"hi",false,null,{}] == False +-- @ +-- +-- Arrays and objects inside arrays match the same way they'd +-- be matched as being on their own. +-- +-- @ +-- [1,"hi",[false,3],{"a":[null]}] \@> [{}] == True +-- [1,"hi",[false,3],{"a":[null]}] \@> [{"a":[]}] == True +-- [1,"hi",[false,3],{"a":[null]}] \@> [{"b":[null]}] == False +-- [1,"hi",[false,3],{"a":[null]}] \@> [[]] == True +-- [1,"hi",[false,3],{"a":[null]}] \@> [[3]] == True +-- [1,"hi",[false,3],{"a":[null]}] \@> [[true,3]] == False +-- @ +-- +-- A regular value has to be a member +-- +-- @ +-- [1,2,"hi",false,null] \@> 1 == True +-- [1,2,"hi",false,null] \@> 5 == False +-- [1,2,"hi",false,null] \@> "hi" == True +-- [1,2,"hi",false,null] \@> false == True +-- [1,2,"hi",false,null] \@> "2" == False +-- @ +-- +-- An object will never match with an array +-- +-- @ +-- [1,2,"hi",[false,3],{"a":null}] \@> {} == False +-- [1,2,"hi",[false,3],{"a":null}] \@> {"a":null} == False +-- @ +-- +-- === __Other values__ +-- +-- For any other JSON values the `(\@>.)` operator +-- functions like an equivalence operator. +-- +-- @ +-- "hello" \@> "hello" == True +-- "hello" \@> \"Hello" == False +-- "hello" \@> "h" == False +-- "hello" \@> {"hello":1} == False +-- "hello" \@> ["hello"] == False +-- +-- 5 \@> 5 == True +-- 5 \@> 5.00 == True +-- 5 \@> 1 == False +-- 5 \@> 7 == False +-- 12345 \@> 1234 == False +-- 12345 \@> 2345 == False +-- 12345 \@> "12345" == False +-- 12345 \@> [1,2,3,4,5] == False +-- +-- true \@> true == True +-- true \@> false == False +-- false \@> true == False +-- true \@> "true" == False +-- +-- null \@> null == True +-- null \@> 23 == False +-- null \@> "null" == False +-- null \@> {} == False +-- @ +-- +-- @since 2.8.2 +(@>.) :: EntityField record Value -> Value -> Filter record +(@>.) field val = Filter field (Left val) $ BackendSpecificFilter " @> " + +-- | Same as '@>.' except the inclusion check is reversed. +-- i.e. is the JSON value on the left hand side included +-- in the JSON value of the right hand side. +-- +-- @since 2.8.2 +(<@.) :: EntityField record Value -> Value -> Filter record +(<@.) field val = Filter field (Left val) $ BackendSpecificFilter " <@ " + + +instance PersistField Value where + toPersistValue = toPersistValueJsonB + fromPersistValue = fromPersistValueJsonB + +instance PersistFieldSql Value where + sqlType = sqlTypeJsonB + +-- FIXME: PersistText might be a bit more efficient, +-- but needs testing/profiling before changing it. +-- (When entering into the DB the type isn't as important as fromPersistValue) +toPersistValueJsonB :: ToJSON a => a -> PersistValue +toPersistValueJsonB = PersistDbSpecific . BSL.toStrict . encode + +fromPersistValueJsonB :: FromJSON a => PersistValue -> Either Text a +fromPersistValueJsonB (PersistText t) = + case eitherDecodeStrict $ TE.encodeUtf8 t of + Left str -> Left $ fromPersistValueParseError "FromJSON" t $ T.pack str + Right v -> Right v +fromPersistValueJsonB (PersistByteString bs) = + case eitherDecodeStrict bs of + Left str -> Left $ fromPersistValueParseError "FromJSON" bs $ T.pack str + Right v -> Right v +fromPersistValueJsonB x = Left $ fromPersistValueError "FromJSON" "string or bytea" x + +-- Constraints on the type are not necessary. +sqlTypeJsonB :: (ToJSON a, FromJSON a) => Proxy a -> SqlType +sqlTypeJsonB _ = SqlOther "JSONB" + + +fromPersistValueError :: Text -- ^ Haskell type, should match Haskell name exactly, e.g. "Int64" + -> Text -- ^ Database type(s), should appear different from Haskell name, e.g. "integer" or "INT", not "Int". + -> PersistValue -- ^ Incorrect value + -> Text -- ^ Error message +fromPersistValueError haskellType databaseType received = T.concat + [ "Failed to parse Haskell type `" + , haskellType + , "`; expected " + , databaseType + , " from database, but received: " + , T.pack (show received) + , ". Potential solution: Check that your database schema matches your Persistent model definitions." + ] + +fromPersistValueParseError :: (Show a) + => Text -- ^ Haskell type, should match Haskell name exactly, e.g. "Int64" + -> a -- ^ Received value + -> Text -- ^ Additional error + -> Text -- ^ Error message +fromPersistValueParseError haskellType received err = T.concat + [ "Failed to parse Haskell type `" + , haskellType + , "`, but received " + , T.pack (show received) + , " | with error: " + , err + ] 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.8.1.1 +version: 2.8.2.0 license: MIT license-file: LICENSE author: Felipe Lessa, Michael Snoyman @@ -32,6 +32,7 @@ , monad-logger >= 0.3.4 , resource-pool exposed-modules: Database.Persist.Postgresql + , Database.Persist.Postgresql.JSON ghc-options: -Wall source-repository head