persistent-postgresql 2.8.1.1 → 2.8.2.0
raw patch · 4 files changed
+223/−20 lines, 4 files
Files
- ChangeLog.md +7/−0
- Database/Persist/Postgresql.hs +19/−19
- Database/Persist/Postgresql/JSON.hs +195/−0
- persistent-postgresql.cabal +2/−1
ChangeLog.md view
@@ -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)
Database/Persist/Postgresql.hs view
@@ -88,7 +88,7 @@ -- string would be @\"host=localhost port=5432 user=test -- dbname=test password=test\"@. Please read libpq's -- documentation at--- <http://www.postgresql.org/docs/9.1/static/libpq-connect.html>+-- <https://www.postgresql.org/docs/current/static/libpq-connect.html> -- 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
+ Database/Persist/Postgresql/JSON.hs view
@@ -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+ ]
persistent-postgresql.cabal view
@@ -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 <michael@snoyman.com>@@ -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