From 12cb525ca4b5b532cebb5e9d8260ed52bd912e21 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Mon, 29 Mar 2021 17:37:17 -0600 Subject: [PATCH 1/9] fix hs-source-dirs --- persistent/persistent.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/persistent/persistent.cabal b/persistent/persistent.cabal index 5ccdbef36..67ab7a388 100644 --- a/persistent/persistent.cabal +++ b/persistent/persistent.cabal @@ -124,7 +124,7 @@ test-suite test , th-lift-instances hs-source-dirs: - . + ./ test/ cpp-options: -DTEST From 0943cce50347dc51fc6f85ad307da90e0b4641c7 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Tue, 30 Mar 2021 07:45:36 -0600 Subject: [PATCH 2/9] persistent-postgresql-2.12.0.0 --- persistent-postgresql/persistent-postgresql.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/persistent-postgresql/persistent-postgresql.cabal b/persistent-postgresql/persistent-postgresql.cabal index c7ea5e3f4..6f5f6501d 100644 --- a/persistent-postgresql/persistent-postgresql.cabal +++ b/persistent-postgresql/persistent-postgresql.cabal @@ -97,3 +97,4 @@ executable conn-kill , bytestring , resource-pool , mtl + default-language: Haskell2010 From c522bbbe833f0bbb674f9a1896f8bd2de6dd92b8 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Tue, 30 Mar 2021 07:46:58 -0600 Subject: [PATCH 3/9] persistent-template-2.12.0.0 --- persistent-template/persistent-template.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/persistent-template/persistent-template.cabal b/persistent-template/persistent-template.cabal index 8d807e6d0..a669b787e 100644 --- a/persistent-template/persistent-template.cabal +++ b/persistent-template/persistent-template.cabal @@ -12,7 +12,7 @@ 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: test/main.hs ChangeLog.md README.md +extra-source-files: ChangeLog.md README.md library build-depends: base >= 4.10 && < 5 From 107af7fafd675c1d0c253534ccddedc7f6d504c2 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Tue, 30 Mar 2021 09:55:50 -0600 Subject: [PATCH 4/9] remove unreleased --- persistent/ChangeLog.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md index 26797bf93..0e2ada329 100644 --- a/persistent/ChangeLog.md +++ b/persistent/ChangeLog.md @@ -1,6 +1,6 @@ # Changelog for persistent -## 2.12.0.1 (unreleased) +## 2.12.0.1 * Refactoring token parsing in quasi module [#1206](https://github.com/yesodweb/persistent/pull/1206) * Removing duplication from TH output [#1202](https://github.com/yesodweb/persistent/pull/1202) From 6d2b90daabfb2e708b98709b9009d88ce4b59bbb Mon Sep 17 00:00:00 2001 From: Matt Parsons Date: Wed, 31 Mar 2021 10:36:36 -0600 Subject: [PATCH 5/9] add upper bound on template-haskell (#1221) --- persistent/persistent.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/persistent/persistent.cabal b/persistent/persistent.cabal index 67ab7a388..a7d473510 100644 --- a/persistent/persistent.cabal +++ b/persistent/persistent.cabal @@ -32,7 +32,7 @@ library , resourcet >= 1.1.10 , scientific , silently - , template-haskell >= 2.11 + , template-haskell >= 2.11 && < 2.17 , text >= 1.2 , time >= 1.6 , transformers >= 0.5 From f102aa8b45a0460a37f51b1ba8c06c9160aee7e4 Mon Sep 17 00:00:00 2001 From: Matt Parsons Date: Thu, 1 Apr 2021 10:41:48 -0600 Subject: [PATCH 6/9] Fix ToJSON for PersistValue (#1223) * Fix JSON encoding for PersistValue * Fix JSON encoding * remove uses, deprecation warning disablers * changelog --- persistent-mysql/Database/Persist/MySQL.hs | 2 +- .../Database/Persist/Postgresql.hs | 1 - persistent-redis/ChangeLog.md | 5 ++++ .../Database/Persist/Redis/Parser.hs | 5 +--- persistent-redis/persistent-redis.cabal | 2 +- persistent/ChangeLog.md | 5 ++++ .../Database/Persist/Class/PersistField.hs | 5 +--- persistent/Database/Persist/Sql/Class.hs | 6 ++-- persistent/Database/Persist/Types/Base.hs | 16 ++++++---- persistent/persistent.cabal | 2 +- persistent/test/main.hs | 30 +++++++++++++++++++ 11 files changed, 58 insertions(+), 21 deletions(-) diff --git a/persistent-mysql/Database/Persist/MySQL.hs b/persistent-mysql/Database/Persist/MySQL.hs index 4f3476abb..c29751819 100644 --- a/persistent-mysql/Database/Persist/MySQL.hs +++ b/persistent-mysql/Database/Persist/MySQL.hs @@ -320,7 +320,7 @@ getGetter field = go (MySQLBase.fieldType field) -- Controversial conversions go MySQLBase.Set _ _ = convertPV PersistText go MySQLBase.Enum _ _ = convertPV PersistText - -- Conversion using PersistDbSpecific + -- Conversion using PersistLiteral go MySQLBase.Geometry _ _ = \_ m -> case m of Just g -> PersistLiteral g diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index 459d69ffc..30e56e872 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -6,7 +6,6 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -fno-warn-deprecations #-} -- Pattern match 'PersistDbSpecific' -- | A postgresql backend for persistent. module Database.Persist.Postgresql diff --git a/persistent-redis/ChangeLog.md b/persistent-redis/ChangeLog.md index 4fface158..0d5669fdb 100644 --- a/persistent-redis/ChangeLog.md +++ b/persistent-redis/ChangeLog.md @@ -1,3 +1,8 @@ +## 2.12.0.1 (unreleased) + +* [#1123](https://github.com/yesodweb/persistent/pull/1223): + * Changed the error message from trying to serialize a `PersistDbSpecific` value into `PersistLiteral_`. + ## 2.12.0.0 * Decomposed `HaskellName` into `ConstraintNameHS`, `EntityNameHS`, `FieldNameHS`. Decomposed `DBName` into `ConstraintNameDB`, `EntityNameDB`, `FieldNameDB` respectively. [#1174](https://github.com/yesodweb/persistent/pull/1174) diff --git a/persistent-redis/Database/Persist/Redis/Parser.hs b/persistent-redis/Database/Persist/Redis/Parser.hs index 5e74b976c..4f878d4de 100644 --- a/persistent-redis/Database/Persist/Redis/Parser.hs +++ b/persistent-redis/Database/Persist/Redis/Parser.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -fno-warn-deprecations #-} -- Pattern match 'PersistDbSpecific' module Database.Persist.Redis.Parser ( redisToPerisistValues , toValue @@ -128,9 +127,7 @@ instance Binary BinPersistValue where put x put (BinPersistValue (PersistArray _)) = throw $ NotSupportedValueType "PersistArray" - put (BinPersistValue (PersistDbSpecific _)) = throw $ NotSupportedValueType "PersistDbSpecific" - put (BinPersistValue (PersistLiteral _)) = throw $ NotSupportedValueType "PersistLiteral" - put (BinPersistValue (PersistLiteralEscaped _)) = throw $ NotSupportedValueType "PersistLiteralEscaped" + put (BinPersistValue (PersistLiteral_ _ _)) = throw $ NotSupportedValueType "PersistLiteral_" put (BinPersistValue (PersistObjectId _)) = throw $ NotSupportedValueType "PersistObjectId" get = do diff --git a/persistent-redis/persistent-redis.cabal b/persistent-redis/persistent-redis.cabal index 89dac54d9..8a52ecb4f 100644 --- a/persistent-redis/persistent-redis.cabal +++ b/persistent-redis/persistent-redis.cabal @@ -1,5 +1,5 @@ name: persistent-redis -version: 2.12.0.0 +version: 2.12.0.1 license: BSD3 license-file: LICENSE author: Pavel Ryzhov diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md index 0e2ada329..87913f4d3 100644 --- a/persistent/ChangeLog.md +++ b/persistent/ChangeLog.md @@ -1,5 +1,10 @@ # Changelog for persistent +## 2.12.0.2 + +* [#1123](https://github.com/yesodweb/persistent/pull/1223) + * Fix JSON encoding for `PersistValue` + ## 2.12.0.1 * Refactoring token parsing in quasi module [#1206](https://github.com/yesodweb/persistent/pull/1206) diff --git a/persistent/Database/Persist/Class/PersistField.hs b/persistent/Database/Persist/Class/PersistField.hs index dce25f32c..8f559aab7 100644 --- a/persistent/Database/Persist/Class/PersistField.hs +++ b/persistent/Database/Persist/Class/PersistField.hs @@ -3,7 +3,6 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PatternGuards, DataKinds, TypeOperators, UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-deprecations #-} -- Pattern match 'PersistDbSpecific' module Database.Persist.Class.PersistField ( PersistField (..) , SomePersistField (..) @@ -113,9 +112,7 @@ instance {-# OVERLAPPING #-} PersistField [Char] where fromPersistValue (PersistBool b) = Right $ Prelude.show b fromPersistValue (PersistList _) = Left $ T.pack "Cannot convert PersistList to String" fromPersistValue (PersistMap _) = Left $ T.pack "Cannot convert PersistMap to String" - fromPersistValue (PersistDbSpecific _) = Left $ T.pack "Cannot convert PersistDbSpecific to String" - fromPersistValue (PersistLiteralEscaped _) = Left $ T.pack "Cannot convert PersistLiteralEscaped to String" - fromPersistValue (PersistLiteral _) = Left $ T.pack "Cannot convert PersistLiteral to String" + fromPersistValue (PersistLiteral_ _ _) = Left $ T.pack "Cannot convert PersistLiteral_ to String" fromPersistValue (PersistArray _) = Left $ T.pack "Cannot convert PersistArray to String" fromPersistValue (PersistObjectId _) = Left $ T.pack "Cannot convert PersistObjectId to String" #endif diff --git a/persistent/Database/Persist/Sql/Class.hs b/persistent/Database/Persist/Sql/Class.hs index 4a3df33be..9a4aa9a71 100644 --- a/persistent/Database/Persist/Sql/Class.hs +++ b/persistent/Database/Persist/Sql/Class.hs @@ -1135,12 +1135,12 @@ extractMaybe = fromMaybe (error "Database.Persist.GenericSql.extractMaybe") -- @ -- import qualified Data.UUID as UUID -- instance 'PersistField' UUID where --- 'toPersistValue' = 'PersistDbSpecific' . toASCIIBytes --- 'fromPersistValue' ('PersistDbSpecific' uuid) = +-- 'toPersistValue' = 'PersistLiteralEncoded' . toASCIIBytes +-- 'fromPersistValue' ('PersistLiteralEncoded' uuid) = -- case fromASCIIBytes uuid of -- 'Nothing' -> 'Left' $ "Model/CustomTypes.hs: Failed to deserialize a UUID; received: " <> T.pack (show uuid) -- 'Just' uuid' -> 'Right' uuid' --- 'fromPersistValue' x = Left $ "File.hs: When trying to deserialize a UUID: expected PersistDbSpecific, received: "-- > <> T.pack (show x) +-- 'fromPersistValue' x = Left $ "File.hs: When trying to deserialize a UUID: expected PersistLiteralEncoded, received: "-- > <> T.pack (show x) -- -- instance 'PersistFieldSql' UUID where -- 'sqlType' _ = 'SqlOther' "uuid" diff --git a/persistent/Database/Persist/Types/Base.hs b/persistent/Database/Persist/Types/Base.hs index 1c92fc2b6..1f6054bc2 100644 --- a/persistent/Database/Persist/Types/Base.hs +++ b/persistent/Database/Persist/Types/Base.hs @@ -637,9 +637,7 @@ fromPersistValueText (PersistList _) = Left "Cannot convert PersistList to Text" fromPersistValueText (PersistMap _) = Left "Cannot convert PersistMap to Text" fromPersistValueText (PersistObjectId _) = Left "Cannot convert PersistObjectId to Text" fromPersistValueText (PersistArray _) = Left "Cannot convert PersistArray to Text" -fromPersistValueText (PersistDbSpecific _) = Left "Cannot convert PersistDbSpecific to Text" -fromPersistValueText (PersistLiteral _) = Left "Cannot convert PersistLiteral to Text" -fromPersistValueText (PersistLiteralEscaped _) = Left "Cannot convert PersistLiteralEscaped to Text" +fromPersistValueText (PersistLiteral_ _ _) = Left "Cannot convert PersistLiteral to Text" instance A.ToJSON PersistValue where toJSON (PersistText t) = A.String $ T.cons 's' t @@ -654,9 +652,15 @@ instance A.ToJSON PersistValue where toJSON PersistNull = A.Null toJSON (PersistList l) = A.Array $ V.fromList $ map A.toJSON l toJSON (PersistMap m) = A.object $ map (second A.toJSON) m - toJSON (PersistDbSpecific b) = A.String $ T.cons 'p' $ TE.decodeUtf8 $ B64.encode b - toJSON (PersistLiteral b) = A.String $ T.cons 'l' $ TE.decodeUtf8 $ B64.encode b - toJSON (PersistLiteralEscaped b) = A.String $ T.cons 'e' $ TE.decodeUtf8 $ B64.encode b + toJSON (PersistLiteral_ litTy b) = + let encoded = TE.decodeUtf8 $ B64.encode b + prefix = + case litTy of + DbSpecific -> 'p' + Unescaped -> 'l' + Escaped -> 'e' + in + A.String $ T.cons prefix encoded toJSON (PersistArray a) = A.Array $ V.fromList $ map A.toJSON a toJSON (PersistObjectId o) = A.toJSON $ showChar 'o' $ showHexLen 8 (bs2i four) $ showHexLen 16 (bs2i eight) "" diff --git a/persistent/persistent.cabal b/persistent/persistent.cabal index a7d473510..26f1c9d27 100644 --- a/persistent/persistent.cabal +++ b/persistent/persistent.cabal @@ -1,5 +1,5 @@ name: persistent -version: 2.12.0.1 +version: 2.12.0.2 license: MIT license-file: LICENSE author: Michael Snoyman diff --git a/persistent/test/main.hs b/persistent/test/main.hs index 6dd534b58..67a2c73e0 100644 --- a/persistent/test/main.hs +++ b/persistent/test/main.hs @@ -18,6 +18,8 @@ import Data.Semigroup ((<>)) #endif import Data.Time import Text.Shakespeare.Text +import Data.Aeson +import qualified Data.ByteString.Char8 as BS8 import Database.Persist.Class.PersistField import Database.Persist.Quasi @@ -870,6 +872,34 @@ Baz fromPersistValue (PersistText "2018-02-27 10:49:42.123") `shouldBe` Right (UTCTime (fromGregorian 2018 02 27) (timeOfDayToTime (TimeOfDay 10 49 42.123))) + describe "PersistValue" $ do + describe "Aeson" $ do + let + testPrefix constr prefixChar bytes = + takePrefix (toJSON (constr (BS8.pack bytes))) + === + String (T.singleton prefixChar) + roundTrip constr bytes = + fromJSON (toJSON (constr (BS8.pack bytes))) + === + Data.Aeson.Success (constr (BS8.pack bytes)) + subject constr prefixChar = do + prop ("encodes with a " ++ [prefixChar] ++ " prefix") $ + testPrefix constr prefixChar + prop "Round Trips" $ + roundTrip constr + + describe "PersistDbSpecific" $ do + subject PersistDbSpecific 'p' + describe "PersistLiteral" $ do + subject PersistLiteral 'l' + describe "PersistLiteralEscaped" $ do + subject PersistLiteralEscaped 'e' + +takePrefix :: Value -> Value +takePrefix (String a) = String (T.take 1 a) +takePrefix a = a + asTokens :: [T.Text] -> [Token] asTokens = fmap Token From bf4c3ae430d7e7ec0351a768783d73e6bd265890 Mon Sep 17 00:00:00 2001 From: Matt Parsons Date: Fri, 2 Apr 2021 09:28:36 -0600 Subject: [PATCH 7/9] Add Editor Tooling Files (#1224) * Add Editor Tooling Files * Add PR template for style * notes and docs --- .editorconfig | 20 ++++++++++++++++ .github/PULL_REQUEST_TEMPLATE.md | 2 ++ .stylish-haskell.yaml | 39 ++++++++++++++++++++++++++++++++ README.md | 5 ++++ development.md | 27 +++++++++++++++++++++- 5 files changed, 92 insertions(+), 1 deletion(-) create mode 100644 .editorconfig create mode 100644 .stylish-haskell.yaml diff --git a/.editorconfig b/.editorconfig new file mode 100644 index 000000000..0f676483f --- /dev/null +++ b/.editorconfig @@ -0,0 +1,20 @@ +# http://editorconfig.org +root = true + +[Makefile] +indent_style = tabs +indent_size = 8 +end_of_line = lf +charset = utf-8 +trim_trailing_whitespace = true +insert_final_newline = true + +[*.{hs,md}] +indent_style = space +indent_size = 4 +tab_width = 4 +end_of_line = lf +charset = utf-8 +trim_trailing_whitespace = true +insert_final_newline = true +max_line_length = 80 diff --git a/.github/PULL_REQUEST_TEMPLATE.md b/.github/PULL_REQUEST_TEMPLATE.md index 769b1063a..b49984d69 100644 --- a/.github/PULL_REQUEST_TEMPLATE.md +++ b/.github/PULL_REQUEST_TEMPLATE.md @@ -2,6 +2,8 @@ Before submitting your PR, check that you've: - [ ] Documented new APIs with [Haddock markup](https://www.haskell.org/haddock/doc/html/index.html) - [ ] Added [`@since` declarations](http://haskell-haddock.readthedocs.io/en/latest/markup.html#since) to the Haddock +- [ ] Ran `stylish-haskell` on any changed files. +- [ ] Adhered to the code style (see the `.editorconfig` file for details) After submitting your PR: diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml new file mode 100644 index 000000000..6c825a0b1 --- /dev/null +++ b/.stylish-haskell.yaml @@ -0,0 +1,39 @@ +steps: + - imports: + align: none + list_align: with_module_name + pad_module_names: false + long_list_align: new_line_multiline + empty_list_align: inherit + list_padding: 7 # length "import " + separate_lists: false + space_surround: false + - language_pragmas: + style: vertical + align: false + remove_redundant: true + - simple_align: + cases: false + top_level_patterns: false + records: false + - trailing_whitespace: {} +indent: 4 +columns: 80 +newline: native +language_extensions: + - BlockArguments + - DataKinds + - DeriveGeneric + - DerivingStrategies + - DerivingVia + - ExplicitForAll + - FlexibleContexts + - MultiParamTypeClasses + - NamedFieldPuns + - OverloadedStrings + - QuantifiedConstraints + - RecordWildCards + - ScopedTypeVariables + - TemplateHaskell + - TypeApplications + - ViewPatterns diff --git a/README.md b/README.md index 313dae3d8..f69a497c9 100644 --- a/README.md +++ b/README.md @@ -34,3 +34,8 @@ Clone the repo and run `stack build` to build all targets. Persistent supports many backends. If you have only some of these installed the [development doc](development.md) shows how to build against a subset of targets. + +## Development + +For more information on how to hack ont he `persistent` set of libraries, see +the [`development.md`](development.md) file. diff --git a/development.md b/development.md index cdcf1090f..6e7a43471 100644 --- a/development.md +++ b/development.md @@ -1,3 +1,28 @@ +# Style Guide + +## `stylish-haskell` + +This repository uses +[`stylish-haskell`](https://hackage.haskell.org/package/stylish-haskell) as an +autoformatter. `stylish-haskell` is inherently limited, so it won't handle +everything, but it will format import lists, extension lists, etc. + +## `editorconfig` + +This repository has an `.editorconfig` file for use with the +[`EditorConfig`](https://editorconfig.org/) tool. It's recommended to install +the tool so that the editor style is picked up automatically. + +## General Style Guide + +Prefer 4 space indentation. If the line gets too long, refactor the code - pull +out named terms into `let` or `where` bindings (or top-level functions). + +Prefer `case` expressions over combinators. Prefer `do` notation over combinators. +It's easier, simpler, and faster to read and modify these forms than more +concise versions, even where the more concise version is faster to write at +first. + # Building with Backends With all required backends installed, `stack build` can build all packages @@ -17,7 +42,7 @@ will fail as will builds for packages for those backends alone: Process exited with code: ExitFailure 1 Configuring mysql-0.1.4... setup: The program 'mysql_config' is required but it could not be found - + > stack build persistent-postgresql ... Process exited with code: ExitFailure 1 From 9f25cb8c7b9bd19ea9df0c7efe3e0a34f2554663 Mon Sep 17 00:00:00 2001 From: Dylan Martin Date: Thu, 8 Apr 2021 12:07:46 -0700 Subject: [PATCH 8/9] adding `upsertWhere` and `upsertManyWhere` to `persistent-postgresql` (#1222) * initial implementation of the upsertWhere * whoops don't commit that * don't export this * updating docs and changelog * remove redundant code * omg hls led me astray * refactoring the connection, updating the changelog, and running stylish :) * continue on errors * put it in the wrong place i don't actually know yaml * jeez maybe this works * maybe it should go here instead * test this on CI * testing a different DB * preparing for the PR * yikes idk what i updated these haddocks incorrectly * Update persistent-postgresql/Database/Persist/Postgresql.hs Co-authored-by: Matt Parsons * moving a postgres-specific util to its own module, other code review ffedback * one last test is failing but I'd love external input on why * last changes * Update persistent-postgresql/Database/Persist/Postgresql.hs Co-authored-by: Matt Parsons * hmmmm I'm close i thinkg * generalized the postgresql changes to PersistQuery * finished implementation, added more tests, removed all todos * haddock update * finishing the rest of the haddocks * don't need to touch Raw * remodeled the data * Update persistent-postgresql/Database/Persist/Postgresql.hs Co-authored-by: Matt Parsons * Update persistent-postgresql/Database/Persist/Postgresql.hs Co-authored-by: Matt Parsons * Update persistent-postgresql/Database/Persist/Postgresql.hs Co-authored-by: Matt Parsons * fix formatting * latest changes real quick * this should all compile but there's no sum type yet. Just taking stock of what we have * remove debug logs * add sum type todo * this should work * we got the tests rocking! * add an assertion to the mysql test * ooops gotta update the mysql test to make it correct * omg DERP * updating tests and also re-running CI Co-authored-by: Matt Parsons --- .github/workflows/haskell.yml | 1 + persistent-mysql/Database/Persist/MySQL.hs | 2 +- .../test/InsertDuplicateUpdate.hs | 3 + persistent-postgresql/ChangeLog.md | 4 + .../Database/Persist/Postgresql.hs | 227 +++++++++++++++++- persistent-postgresql/README.md | 2 +- .../persistent-postgresql.cabal | 1 + persistent-postgresql/test/PgInit.hs | 2 +- persistent-postgresql/test/UpsertWhere.hs | 178 ++++++++++++++ persistent-postgresql/test/main.hs | 3 + persistent/Database/Persist/Sql.hs | 4 + .../Persist/Sql/Orphan/PersistQuery.hs | 61 +++-- persistent/Database/Persist/Sql/Util.hs | 3 +- 13 files changed, 462 insertions(+), 29 deletions(-) create mode 100644 persistent-postgresql/test/UpsertWhere.hs diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index df9e14926..af8b007f5 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -82,4 +82,5 @@ jobs: - run: cabal v2-build all --disable-optimization $CONFIG - run: cabal v2-test all --disable-optimization $CONFIG - run: cabal v2-haddock all $CONFIG + continue-on-error: true - run: cabal v2-sdist all diff --git a/persistent-mysql/Database/Persist/MySQL.hs b/persistent-mysql/Database/Persist/MySQL.hs index c29751819..d6f65dc98 100644 --- a/persistent-mysql/Database/Persist/MySQL.hs +++ b/persistent-mysql/Database/Persist/MySQL.hs @@ -1428,7 +1428,7 @@ copyField = CopyField -- [] -- @ -- --- Once we run that code on the datahase, the new data set looks like this: +-- Once we run that code on the database, the new data set looks like this: -- -- > items: -- > +------+-------------+-------+----------+ diff --git a/persistent-mysql/test/InsertDuplicateUpdate.hs b/persistent-mysql/test/InsertDuplicateUpdate.hs index 595d13b60..437120792 100644 --- a/persistent-mysql/test/InsertDuplicateUpdate.hs +++ b/persistent-mysql/test/InsertDuplicateUpdate.hs @@ -61,12 +61,15 @@ specs = describe "DuplicateKeyUpdate" $ do dbItems <- map entityVal <$> selectList [] [] sort dbItems @== sort (newItem : items) it "updates existing records" $ db $ do + let postUpdate = map (\i -> i { itemQuantity = fmap (+1) (itemQuantity i) }) items deleteWhere ([] :: [Filter Item]) insertMany_ items insertManyOnDuplicateKeyUpdate items [] [ItemQuantity +=. Just 1] + dbItems <- sort . fmap entityVal <$> selectList [] [] + dbItems @== sort postUpdate it "only copies passing values" $ db $ do deleteWhere ([] :: [Filter Item]) insertMany_ items diff --git a/persistent-postgresql/ChangeLog.md b/persistent-postgresql/ChangeLog.md index 6350581ef..7fce26302 100644 --- a/persistent-postgresql/ChangeLog.md +++ b/persistent-postgresql/ChangeLog.md @@ -1,5 +1,9 @@ # Changelog for persistent-postgresql +## 2.12.1.0 + +* Added `upsertWhere` and `upsertManyWhere` to `persistent-postgresql`. [#1222](https://github.com/yesodweb/persistent/pull/1222). + ## 2.12.0.0 * Decomposed `HaskellName` into `ConstraintNameHS`, `EntityNameHS`, `FieldNameHS`. Decomposed `DBName` into `ConstraintNameDB`, `EntityNameDB`, `FieldNameDB` respectively. [#1174](https://github.com/yesodweb/persistent/pull/1174) diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index 30e56e872..5c676a274 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -1,5 +1,9 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -20,8 +24,16 @@ module Database.Persist.Postgresql , createPostgresqlPoolWithConf , module Database.Persist.Sql , ConnectionString + , HandleUpdateCollision + , copyField + , copyUnlessNull + , copyUnlessEmpty + , copyUnlessEq + , excludeNotEqualToOriginal , PostgresConf (..) , PgInterval (..) + , upsertWhere + , upsertManyWhere , openSimpleConn , openSimpleConnWithVersion , tableName @@ -49,7 +61,7 @@ import Control.Monad import Control.Monad.Except import Control.Monad.IO.Unlift (MonadIO (..), MonadUnliftIO) import Control.Monad.Logger (MonadLoggerIO, runNoLoggingT) -import Control.Monad.Trans.Reader (runReaderT) +import Control.Monad.Trans.Reader (ReaderT(..), runReaderT, asks) import Control.Monad.Trans.Writer (WriterT(..), runWriterT) import qualified Blaze.ByteString.Builder.Char8 as BBB @@ -65,7 +77,7 @@ import qualified Data.ByteString.Char8 as B8 import Data.Char (ord) import Data.Conduit import qualified Data.Conduit.List as CL -import Data.Data +import Data.Data ( Data, Typeable ) import Data.Either (partitionEithers) import Data.Fixed (Fixed(..), Pico) import Data.Function (on) @@ -79,6 +91,7 @@ import qualified Data.List.NonEmpty as NEL import qualified Data.Map as Map import Data.Maybe import Data.Monoid ((<>)) +import qualified Data.Monoid as Monoid import Data.Pool (Pool) import Data.String.Conversions.Monomorphic (toStrictByteString) import Data.Text (Text) @@ -396,7 +409,6 @@ insertSql' ent vals = ] ] - upsertSql' :: EntityDef -> NonEmpty (FieldNameHS, FieldNameDB) -> Text -> Text upsertSql' ent uniqs updateVal = T.concat @@ -1495,6 +1507,7 @@ escapeE = escapeWith escape escapeF :: FieldNameDB -> Text escapeF = escapeWith escape + escape :: Text -> Text escape s = T.pack $ '"' : go (T.unpack s) ++ "\"" @@ -1737,6 +1750,214 @@ repsertManySql ent n = putManySql' conflictColumns fields ent n fields = keyAndEntityFields ent conflictColumns = escapeF . fieldDB <$> entityKeyFields ent +-- | This type is used to determine how to update rows using Postgres' +-- @INSERT ... ON CONFLICT KEY UPDATE@ functionality, exposed via +-- 'upsertWhere' and 'upsertManyWhere' in this library. +-- +-- @since 2.12.1.0 +data HandleUpdateCollision record where + -- | Copy the field directly from the record. + CopyField :: EntityField record typ -> HandleUpdateCollision record + -- | Only copy the field if it is not equal to the provided value. + CopyUnlessEq :: PersistField typ => EntityField record typ -> typ -> HandleUpdateCollision record + +-- | Copy the field into the database only if the value in the +-- corresponding record is non-@NULL@. +-- +-- @since 2.12.1.0 +copyUnlessNull :: PersistField typ => EntityField record (Maybe typ) -> HandleUpdateCollision record +copyUnlessNull field = CopyUnlessEq field Nothing + +-- | Copy the field into the database only if the value in the +-- corresponding record is non-empty, where "empty" means the Monoid +-- definition for 'mempty'. Useful for 'Text', 'String', 'ByteString', etc. +-- +-- The resulting 'HandleUpdateCollision' type is useful for the +-- 'upsertManyWhere' function. +-- +-- @since 2.12.1.0 +copyUnlessEmpty :: (Monoid.Monoid typ, PersistField typ) => EntityField record typ -> HandleUpdateCollision record +copyUnlessEmpty field = CopyUnlessEq field Monoid.mempty + +-- | Copy the field into the database only if the field is not equal to the +-- provided value. This is useful to avoid copying weird nullary data into +-- the database. +-- +-- The resulting 'HandleUpdateCollision' type is useful for the +-- 'upsertMany' function. +-- +-- @since 2.12.1.0 +copyUnlessEq :: PersistField typ => EntityField record typ -> typ -> HandleUpdateCollision record +copyUnlessEq = CopyUnlessEq + +-- | Copy the field directly from the record. +-- +-- @since 2.12.1.0 +copyField :: PersistField typ => EntityField record typ -> HandleUpdateCollision record +copyField = CopyField + +-- | Postgres specific 'upsertWhere'. This method does the following: +-- It will insert a record if no matching unique key exists. +-- If a unique key exists, it will update the relevant field with a user-supplied value, however, +-- it will only do this update on a user-supplied condition. +-- For example, here's how this method could be called like such: +-- +-- @ +-- upsertWhere record [recordField =. newValue] [recordField /= newValue] +-- @ +-- +-- Called thusly, this method will insert a new record (if none exists) OR update a recordField with a new value +-- assuming the condition in the last block is met. +-- +-- @since 2.12.1.0 +upsertWhere + :: ( backend ~ PersistEntityBackend record + , PersistEntity record + , PersistEntityBackend record ~ SqlBackend + , MonadIO m + , PersistStore backend + , BackendCompatible SqlBackend backend + ) + => record + -> [Update record] + -> [Filter record] + -> ReaderT backend m () +upsertWhere record updates filts = + upsertManyWhere [record] [] updates filts + +-- | Exclude any record field if it doesn't match the filter record. Used only in `upsertWhere` and +-- `upsertManyWhere` +-- +-- @since 2.12.1.0 +-- TODO: we could probably make a sum type for the `Filter` record that's passed into the `upserWhere` and +-- `upsertManyWhere` methods that has similar behavior to the HandleCollisionUpdate type. +excludeNotEqualToOriginal :: + (PersistField typ + , PersistEntity rec) => + EntityField rec typ -> + Filter rec +excludeNotEqualToOriginal field = + Filter + { filterField = + field, + filterFilter = + Ne, + filterValue = + UnsafeValue $ + PersistLiteral_ + Unescaped + bsForExcludedField + } + where + bsForExcludedField = + T.encodeUtf8 $ + "EXCLUDED." + <> fieldName field + +-- | Postgres specific 'upsertManyWhere'. This method does the following: +-- It will insert a record if no matching unique key exists. +-- If a unique key exists, it will update the relevant field with a user-supplied value, however, +-- it will only do this update on a user-supplied condition. +-- For example, here's how this method could be called like such: +-- +-- upsertManyWhere [record] [recordField =. newValue] [recordField /= newValue] +-- +-- Called thusly, this method will insert a new record (if none exists) OR update a recordField with a new value +-- assuming the condition in the last block is met. +-- +-- -- @since 2.12.1.0 +upsertManyWhere :: + forall record backend m. + ( backend ~ PersistEntityBackend record, + BackendCompatible SqlBackend backend, + PersistEntityBackend record ~ SqlBackend, + PersistEntity record, + MonadIO m + ) => + -- | A list of the records you want to insert, or update + [record] -> + -- | A list of the fields you want to copy over. + [HandleUpdateCollision record] -> + -- | A list of the updates to apply that aren't dependent on the record being inserted. + [Update record] -> + -- | A filter condition that dictates the scope of the updates + [Filter record] -> + ReaderT backend m () +upsertManyWhere [] _ _ _ = return () +upsertManyWhere records fieldValues updates filters = do + conn <- asks projectBackend + uncurry rawExecute $ + mkBulkUpsertQuery records conn fieldValues updates filters + +-- | This creates the query for 'upsertManyWhere'. If you +-- provide an empty list of updates to perform, then it will generate +-- a dummy/no-op update using the first field of the record. This avoids +-- duplicate key exceptions. +mkBulkUpsertQuery + :: (PersistEntity record, PersistEntityBackend record ~ SqlBackend) + => [record] -- ^ A list of the records you want to insert, or update + -> SqlBackend + -> [HandleUpdateCollision record] -- ^ A list of the fields you want to copy over. + -> [Update record] -- ^ A list of the updates to apply that aren't dependent on the record being inserted. + -> [Filter record] -- ^ A filter condition that dictates the scope of the updates + -> (Text, [PersistValue]) +mkBulkUpsertQuery records conn fieldValues updates filters = + (q, recordValues <> updsValues <> copyUnlessValues <> whereVals) + where + mfieldDef x = case x of + CopyField rec -> Right (fieldDbToText (persistFieldDef rec)) + CopyUnlessEq rec val -> Left (fieldDbToText (persistFieldDef rec), toPersistValue val) + (fieldsToMaybeCopy, updateFieldNames) = partitionEithers $ map mfieldDef fieldValues + fieldDbToText = escapeF . fieldDB + entityDef' = entityDef records + conflictColumns = escapeF . fieldDB <$> entityKeyFields entityDef' + firstField = case entityFieldNames of + [] -> error "The entity you're trying to insert does not have any fields." + (field:_) -> field + entityFieldNames = map fieldDbToText (entityFields entityDef') + nameOfTable = escapeE . entityDB $ entityDef' + copyUnlessValues = map snd fieldsToMaybeCopy + recordValues = concatMap (map toPersistValue . toPersistFields) records + recordPlaceholders = Util.commaSeparated $ map (Util.parenWrapped . Util.commaSeparated . map (const "?") . toPersistFields) records + mkCondFieldSet n _ = + T.concat + [ n + , "=COALESCE(" + , "NULLIF(" + , "EXCLUDED." + , n + , "," + , "?" + , ")" + , "," + , nameOfTable + , "." + , n + ,")" + ] + condFieldSets = map (uncurry mkCondFieldSet) fieldsToMaybeCopy + fieldSets = map (\n -> T.concat [n, "=EXCLUDED.", n, ""]) updateFieldNames + upds = map (Util.mkUpdateText' (escapeF) (\n -> T.concat [nameOfTable, ".", n])) updates + updsValues = map (\(Update _ val _) -> toPersistValue val) updates + (wher, whereVals) = if null filters + then ("", []) + else (filterClauseWithVals (Just PrefixTableName) conn filters) + updateText = case fieldSets <> upds <> condFieldSets of + [] -> T.concat [firstField, "=EXCLUDED.", firstField] + xs -> Util.commaSeparated xs + q = T.concat + [ "INSERT INTO " + , nameOfTable + , Util.parenWrapped . Util.commaSeparated $ entityFieldNames + , " VALUES " + , recordPlaceholders + , " ON CONFLICT " + , Util.parenWrapped $ Util.commaSeparated $ conflictColumns + , " DO UPDATE SET " + , updateText + , wher + ] + putManySql' :: [Text] -> [FieldDef] -> EntityDef -> Int -> Text putManySql' conflictColumns (filter isFieldNotGenerated -> fields) ent n = q where diff --git a/persistent-postgresql/README.md b/persistent-postgresql/README.md index 7318e21ea..219bb184a 100644 --- a/persistent-postgresql/README.md +++ b/persistent-postgresql/README.md @@ -21,5 +21,5 @@ $ createdb test The tests do not pass a test and expect to connect with the `postgres` user. Ensure that peer authentication is allowed for this. -An easy/insecure way to do this is to set the `METHOD` to `trust` for all the login methods in `/etc/postgresql/XX/main/pg_hba.coinf`. +An easy/insecure way to do this is to set the `METHOD` to `trust` for all the login methods in `/etc/postgresql/XX/main/pg_hba.conf`. (TODO: make this better?) diff --git a/persistent-postgresql/persistent-postgresql.cabal b/persistent-postgresql/persistent-postgresql.cabal index 6f5f6501d..39bf8c070 100644 --- a/persistent-postgresql/persistent-postgresql.cabal +++ b/persistent-postgresql/persistent-postgresql.cabal @@ -53,6 +53,7 @@ test-suite test JSONTest CustomConstraintTest PgIntervalTest + UpsertWhere ghc-options: -Wall build-depends: base >= 4.9 && < 5 diff --git a/persistent-postgresql/test/PgInit.hs b/persistent-postgresql/test/PgInit.hs index d2fcb85dd..8c9906ce3 100644 --- a/persistent-postgresql/test/PgInit.hs +++ b/persistent-postgresql/test/PgInit.hs @@ -56,7 +56,7 @@ 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) diff --git a/persistent-postgresql/test/UpsertWhere.hs b/persistent-postgresql/test/UpsertWhere.hs new file mode 100644 index 000000000..626f83443 --- /dev/null +++ b/persistent-postgresql/test/UpsertWhere.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE DataKinds, FlexibleInstances, MultiParamTypeClasses, ExistentialQuantification #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE StandaloneDeriving #-} + +module UpsertWhere where + +import Data.List (sort) + +import Database.Persist.Postgresql +import PgInit + +share [mkPersist sqlSettings, mkMigrate "upsertWhereMigrate"] [persistLowerCase| + Item + name Text sqltype=varchar(80) + description Text + price Double Maybe + quantity Int Maybe + + Primary name + deriving Eq Show Ord + +|] + +specs :: Spec +specs = describe "UpsertWhere" $ do + let item1 = Item "item1" "" (Just 3) Nothing + item2 = Item "item2" "hello world" Nothing (Just 2) + items = [item1, item2] + + describe "upsertWhere" $ do + it "inserts appropriately" $ runConnAssert $ do + deleteWhere ([] :: [Filter Item]) + upsertWhere item1 [ItemDescription =. "i am item 1"] [] + Just item <- get (ItemKey "item1") + item @== item1 + it "performs only updates given if record already exists" $ runConnAssert $ do + deleteWhere ([] :: [Filter Item]) + let newDescription = "I am a new description" + insert_ item1 + upsertWhere + (Item "item1" "i am inserted description" (Just 1) (Just 2)) + [ItemDescription =. newDescription] + [] + Just item <- get (ItemKey "item1") + item @== item1 { itemDescription = newDescription } + + describe "upsertManyWhere" $ do + it "inserts fresh records" $ runConnAssert $ do + deleteWhere ([] :: [Filter Item]) + insertMany_ items + let newItem = Item "item3" "fresh" Nothing Nothing + upsertManyWhere + (newItem : items) + [copyField ItemDescription] + [] + [] + dbItems <- map entityVal <$> selectList [] [] + sort dbItems @== sort (newItem : items) + it "updates existing records" $ runConnAssert $ do + deleteWhere ([] :: [Filter Item]) + let postUpdate = map (\i -> i { itemQuantity = fmap (+1) (itemQuantity i) }) items + insertMany_ items + upsertManyWhere + items + [] + [ItemQuantity +=. Just 1] + [] + dbItems <- sort . fmap entityVal <$> selectList [] [] + dbItems @== sort postUpdate + it "only copies passing values" $ runConnAssert $ do + deleteWhere ([] :: [Filter Item]) + insertMany_ items + let newItems = map (\i -> i { itemQuantity = Just 0, itemPrice = fmap (*2) (itemPrice i) }) items + postUpdate = map (\i -> i { itemPrice = fmap (*2) (itemPrice i) }) items + upsertManyWhere + newItems + [ + copyUnlessEq ItemQuantity (Just 0) + , copyField ItemPrice + ] + [] + [] + dbItems <- sort . fmap entityVal <$> selectList [] [] + dbItems @== sort postUpdate + it "inserts without modifying existing records if no updates specified" $ runConnAssert $ do + let newItem = Item "item3" "hi friends!" Nothing Nothing + deleteWhere ([] :: [Filter Item]) + insertMany_ items + upsertManyWhere + (newItem : items) + [] + [] + [] + dbItems <- sort . fmap entityVal <$> selectList [] [] + dbItems @== sort (newItem : items) + it "inserts without modifying existing records if no updates specified and there's a filter with True condition" $ + runConnAssert $ do + let newItem = Item "item3" "hi friends!" Nothing Nothing + deleteWhere ([] :: [Filter Item]) + insertMany_ items + upsertManyWhere + (newItem : items) + [] + [] + [ItemDescription ==. "hi friends!"] + dbItems <- sort . fmap entityVal <$> selectList [] [] + dbItems @== sort (newItem : items) + it "inserts without updating existing records if there are updates specified but there's a filter with a False condition" $ + runConnAssert $ do + let newItem = Item "item3" "hi friends!" Nothing Nothing + deleteWhere ([] :: [Filter Item]) + insertMany_ items + upsertManyWhere + (newItem : items) + [] + [ItemQuantity +=. Just 1] + [ItemDescription ==. "hi friends!"] + dbItems <- sort . fmap entityVal <$> selectList [] [] + dbItems @== sort (newItem : items) + it "inserts new records but does not update existing records if there are updates specified but the modification condition is False" $ + runConnAssert $ do + let newItem = Item "item3" "hi friends!" Nothing Nothing + deleteWhere ([] :: [Filter Item]) + insertMany_ items + upsertManyWhere + (newItem : items) + [] + [ItemQuantity +=. Just 1] + [excludeNotEqualToOriginal ItemDescription] + dbItems <- sort . fmap entityVal <$> selectList [] [] + dbItems @== sort (newItem : items) + it "inserts new records and updates existing records if there are updates specified and the modification condition is True (because it's empty)" $ + runConnAssert $ do + let newItem = Item "item3" "hello world" Nothing Nothing + postUpdate = map (\i -> i {itemQuantity = fmap (+ 1) (itemQuantity i)}) items + deleteWhere ([] :: [Filter Item]) + insertMany_ items + upsertManyWhere + (newItem : items) + [] + [ItemQuantity +=. Just 1] + [] + dbItems <- sort . fmap entityVal <$> selectList [] [] + dbItems @== sort (newItem : postUpdate) + it "inserts new records and updates existing records if there are updates specified and the modification filter condition is triggered" $ + runConnAssert $ do + let newItem = Item "item3" "hi friends!" Nothing Nothing + postUpdate = map (\i -> i {itemQuantity = fmap (+1) (itemQuantity i)}) items + deleteWhere ([] :: [Filter Item]) + insertMany_ items + upsertManyWhere + (newItem : items) + [ + copyUnlessEq ItemDescription "hi friends!" + , copyField ItemPrice + ] + [ItemQuantity +=. Just 1] + [ItemDescription !=. "bye friends!"] + dbItems <- sort . fmap entityVal <$> selectList [] [] + dbItems @== sort (newItem : postUpdate) + it "inserts an item and doesn't apply the update if the filter condition is triggered" $ + runConnAssert $ do + let newItem = Item "item3" "hello world" Nothing Nothing + deleteWhere ([] :: [Filter Item]) + insertMany_ items + upsertManyWhere + (newItem : items) + [] + [ItemQuantity +=. Just 1] + [excludeNotEqualToOriginal ItemDescription] + dbItems <- sort . fmap entityVal <$> selectList [] [] + dbItems @== sort (newItem : items) diff --git a/persistent-postgresql/test/main.hs b/persistent-postgresql/test/main.hs index 6c0c47ee6..60543a349 100644 --- a/persistent-postgresql/test/main.hs +++ b/persistent-postgresql/test/main.hs @@ -51,6 +51,7 @@ import qualified TransactionLevelTest import qualified TreeTest import qualified UniqueTest import qualified UpsertTest +import qualified UpsertWhere import qualified CustomConstraintTest import qualified LongIdentifierTest import qualified PgIntervalTest @@ -128,6 +129,7 @@ main = do , ForeignKey.compositeMigrate , MigrationTest.migrationMigrate , PgIntervalTest.pgIntervalMigrate + , UpsertWhere.upsertWhereMigrate ] PersistentTest.cleanDB ForeignKey.cleanDB @@ -195,6 +197,7 @@ main = do LongIdentifierTest.specsWith runConnAssertUseConf -- Have at least one test use the conf variant of connecting to Postgres, to improve test coverage. JSONTest.specs CustomConstraintTest.specs + UpsertWhere.specs PgIntervalTest.specs ArrayAggTest.specs GeneratedColumnTestSQL.specsWith runConnAssert diff --git a/persistent/Database/Persist/Sql.hs b/persistent/Database/Persist/Sql.hs index a0e802507..33676da55 100644 --- a/persistent/Database/Persist/Sql.hs +++ b/persistent/Database/Persist/Sql.hs @@ -12,6 +12,10 @@ module Database.Persist.Sql , rawSql , deleteWhereCount , updateWhereCount + , filterClause + , filterClauseHelper + , filterClauseWithVals + , FilterTablePrefix (..) , transactionSave , transactionSaveWithIsolation , transactionUndo diff --git a/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs b/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs index 3dc784292..a593bf4e1 100644 --- a/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs +++ b/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs @@ -6,6 +6,10 @@ module Database.Persist.Sql.Orphan.PersistQuery ( deleteWhereCount , updateWhereCount + , filterClause + , filterClauseHelper + , filterClauseWithVals + , FilterTablePrefix (..) , decorateSQLWithLimitOffset ) where @@ -36,7 +40,7 @@ instance PersistQueryRead SqlBackend where conn <- ask let wher = if null filts then "" - else filterClause False conn filts + else filterClause Nothing conn filts let sql = mconcat [ "SELECT COUNT(*) FROM " , connEscapeTableName conn t @@ -59,7 +63,7 @@ instance PersistQueryRead SqlBackend where conn <- ask let wher = if null filts then "" - else filterClause False conn filts + else filterClause Nothing conn filts let sql = mconcat [ "SELECT EXISTS(SELECT 1 FROM " , connEscapeTableName conn t @@ -93,7 +97,7 @@ instance PersistQueryRead SqlBackend where t = entityDef $ dummyFromFilts filts wher conn = if null filts then "" - else filterClause False conn filts + else filterClause Nothing conn filts ord conn = case map (orderClause False conn) orders of [] -> "" @@ -119,7 +123,7 @@ instance PersistQueryRead SqlBackend where wher conn = if null filts then "" - else filterClause False conn filts + else filterClause Nothing conn filts sql conn = connLimitOffset conn (limit,offset) (not (null orders)) $ mconcat [ "SELECT " , cols conn @@ -183,7 +187,7 @@ deleteWhereCount filts = withCompatibleBackend $ do let t = entityDef $ dummyFromFilts filts let wher = if null filts then "" - else filterClause False conn filts + else filterClause Nothing conn filts sql = mconcat [ "DELETE FROM " , connEscapeTableName conn t @@ -203,7 +207,7 @@ updateWhereCount filts upds = withCompatibleBackend $ do conn <- ask let wher = if null filts then "" - else filterClause False conn filts + else filterClause Nothing conn filts let sql = mconcat [ "UPDATE " , connEscapeTableName conn t @@ -217,26 +221,30 @@ updateWhereCount filts upds = withCompatibleBackend $ do where t = entityDef $ dummyFromFilts filts -fieldName :: forall record typ. (PersistEntity record, PersistEntityBackend record ~ SqlBackend) => EntityField record typ -> FieldNameDB +fieldName :: forall record typ. (PersistEntity record) => EntityField record typ -> FieldNameDB fieldName f = fieldDB $ persistFieldDef f dummyFromFilts :: [Filter v] -> Maybe v dummyFromFilts _ = Nothing -getFiltsValues :: forall val. (PersistEntity val, PersistEntityBackend val ~ SqlBackend) +getFiltsValues :: forall val. (PersistEntity val) => SqlBackend -> [Filter val] -> [PersistValue] -getFiltsValues conn = snd . filterClauseHelper False False conn OrNullNo +getFiltsValues conn = snd . filterClauseHelper Nothing False conn OrNullNo data OrNull = OrNullYes | OrNullNo -filterClauseHelper :: (PersistEntity val, PersistEntityBackend val ~ SqlBackend) - => Bool -- ^ include table name? - -> Bool -- ^ include WHERE? +data FilterTablePrefix + = PrefixTableName + | PrefixExcluded + +filterClauseHelper :: (PersistEntity val) + => Maybe FilterTablePrefix -- ^ include table name or PostgresSQL EXCLUDED + -> Bool -- ^ include WHERE -> SqlBackend -> OrNull -> [Filter val] -> (Text, [PersistValue]) -filterClauseHelper includeTable includeWhere conn orNull filters = +filterClauseHelper tablePrefix includeWhere conn orNull filters = (if not (T.null sql) && includeWhere then " WHERE " <> sql else sql, vals) @@ -356,7 +364,9 @@ filterClauseHelper includeTable includeWhere conn orNull filters = orNullSuffix = case orNull of - OrNullYes -> mconcat [" OR ", name, " IS NULL"] + OrNullYes -> mconcat [" OR " + , name + , " IS NULL"] OrNullNo -> "" isNull = PersistNull `elem` allVals @@ -364,10 +374,10 @@ filterClauseHelper includeTable includeWhere conn orNull filters = allVals = filterValueToPersistValues value tn = connEscapeTableName conn $ entityDef $ dummyFromFilts [Filter field value pfilter] name = - (if includeTable - then ((tn <> ".") <>) - else id) - $ connEscapeFieldName conn (fieldName field) + case tablePrefix of + Just PrefixTableName -> ((tn <> ".") <>) $ connEscapeFieldName conn (fieldName field) + Just PrefixExcluded -> (("EXCLUDED.") <>) $ connEscapeFieldName conn (fieldName field) + _ -> id $ connEscapeFieldName conn (fieldName field) qmarks = case value of FilterValue{} -> "(?)" UnsafeValue{} -> "(?)" @@ -387,14 +397,21 @@ filterClauseHelper includeTable includeWhere conn orNull filters = showSqlFilter NotIn = " NOT IN " showSqlFilter (BackendSpecificFilter s) = s -filterClause :: (PersistEntity val, PersistEntityBackend val ~ SqlBackend) - => Bool -- ^ include table name? +filterClause :: (PersistEntity val) + => Maybe FilterTablePrefix -- ^ include table name or EXCLUDED -> SqlBackend -> [Filter val] -> Text filterClause b c = fst . filterClauseHelper b True c OrNullNo -orderClause :: (PersistEntity val, PersistEntityBackend val ~ SqlBackend) +filterClauseWithVals :: (PersistEntity val) + => Maybe FilterTablePrefix -- ^ include table name or EXCLUDED + -> SqlBackend + -> [Filter val] + -> (Text, [PersistValue]) +filterClauseWithVals b c = filterClauseHelper b True c OrNullNo + +orderClause :: (PersistEntity val) => Bool -- ^ include the table name -> SqlBackend -> SelectOpt val @@ -410,7 +427,7 @@ orderClause includeTable conn o = tn = connEscapeTableName conn (entityDef $ dummyFromOrder o) - name :: (PersistEntityBackend record ~ SqlBackend, PersistEntity record) + name :: (PersistEntity record) => EntityField record typ -> Text name x = (if includeTable diff --git a/persistent/Database/Persist/Sql/Util.hs b/persistent/Database/Persist/Sql/Util.hs index 980cc6e08..d68e55320 100644 --- a/persistent/Database/Persist/Sql/Util.hs +++ b/persistent/Database/Persist/Sql/Util.hs @@ -207,6 +207,7 @@ commaSeparated = T.intercalate ", " mkUpdateText :: PersistEntity record => SqlBackend -> Update record -> Text mkUpdateText conn = mkUpdateText' (connEscapeFieldName conn) id +-- TODO: incorporate the table names into a sum type mkUpdateText' :: PersistEntity record => (FieldNameDB -> Text) -> (Text -> Text) -> Update record -> Text mkUpdateText' escapeName refColumn x = case updateUpdate x of @@ -223,7 +224,7 @@ mkUpdateText' escapeName refColumn x = parenWrapped :: Text -> Text parenWrapped t = T.concat ["(", t, ")"] --- | Make a list 'PersistValue' suitable for detabase inserts. Pairs nicely +-- | Make a list 'PersistValue' suitable for database inserts. Pairs nicely -- with the function 'mkInsertPlaceholders'. -- -- Does not include generated columns. From eaa7d9b21cde1ff2b6ed240ba55483ca65477aeb Mon Sep 17 00:00:00 2001 From: Matt Parsons Date: Thu, 8 Apr 2021 14:02:51 -0600 Subject: [PATCH 9/9] persistent-2.12.1.0 (#1226) * persistent-2.12.1.0 * stylish haskell * bump version numbers --- .../Database/Persist/Postgresql.hs | 30 +++++++++---------- .../persistent-postgresql.cabal | 4 +-- persistent/ChangeLog.md | 10 +++++-- persistent/Database/Persist/Sql.hs | 11 ++++--- .../Persist/Sql/Orphan/PersistQuery.hs | 27 +++++++++++++++-- persistent/persistent.cabal | 2 +- 6 files changed, 55 insertions(+), 29 deletions(-) diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index 5c676a274..73c967fb9 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -1,9 +1,9 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -47,29 +47,29 @@ module Database.Persist.Postgresql import qualified Database.PostgreSQL.LibPQ as LibPQ import qualified Database.PostgreSQL.Simple as PG -import qualified Database.PostgreSQL.Simple.Internal as PG import qualified Database.PostgreSQL.Simple.FromField as PGFF +import qualified Database.PostgreSQL.Simple.Internal as PG +import Database.PostgreSQL.Simple.Ok (Ok(..)) 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.Simple.Types as PG import Control.Arrow import Control.Exception (Exception, throw, throwIO) import Control.Monad import Control.Monad.Except -import Control.Monad.IO.Unlift (MonadIO (..), MonadUnliftIO) +import Control.Monad.IO.Unlift (MonadIO(..), MonadUnliftIO) import Control.Monad.Logger (MonadLoggerIO, runNoLoggingT) -import Control.Monad.Trans.Reader (ReaderT(..), runReaderT, asks) +import Control.Monad.Trans.Reader (ReaderT(..), asks, runReaderT) import Control.Monad.Trans.Writer (WriterT(..), runWriterT) import qualified Blaze.ByteString.Builder.Char8 as BBB import Data.Acquire (Acquire, mkAcquire, with) import Data.Aeson import Data.Aeson.Types (modifyFailure) -import qualified Data.Attoparsec.Text as AT import qualified Data.Attoparsec.ByteString.Char8 as P +import qualified Data.Attoparsec.Text as AT import Data.Bits ((.&.)) import Data.ByteString (ByteString) import qualified Data.ByteString.Builder as BB @@ -77,16 +77,16 @@ import qualified Data.ByteString.Char8 as B8 import Data.Char (ord) import Data.Conduit import qualified Data.Conduit.List as CL -import Data.Data ( Data, Typeable ) +import Data.Data (Data, Typeable) import Data.Either (partitionEithers) import Data.Fixed (Fixed(..), Pico) import Data.Function (on) +import Data.IORef import Data.Int (Int64) import qualified Data.IntMap as I -import Data.IORef -import Data.List (find, sort, groupBy, foldl') -import Data.List.NonEmpty (NonEmpty) +import Data.List (find, foldl', groupBy, sort) import qualified Data.List as List +import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NEL import qualified Data.Map as Map import Data.Maybe @@ -99,7 +99,7 @@ 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, NominalDiffTime, localTimeToUTC) +import Data.Time (NominalDiffTime, localTimeToUTC, utc) import System.Environment (getEnvironment) import Database.Persist.Sql @@ -1808,7 +1808,7 @@ copyField = CopyField -- -- Called thusly, this method will insert a new record (if none exists) OR update a recordField with a new value -- assuming the condition in the last block is met. --- +-- -- @since 2.12.1.0 upsertWhere :: ( backend ~ PersistEntityBackend record @@ -1939,7 +1939,7 @@ mkBulkUpsertQuery records conn fieldValues updates filters = fieldSets = map (\n -> T.concat [n, "=EXCLUDED.", n, ""]) updateFieldNames upds = map (Util.mkUpdateText' (escapeF) (\n -> T.concat [nameOfTable, ".", n])) updates updsValues = map (\(Update _ val _) -> toPersistValue val) updates - (wher, whereVals) = if null filters + (wher, whereVals) = if null filters then ("", []) else (filterClauseWithVals (Just PrefixTableName) conn filters) updateText = case fieldSets <> upds <> condFieldSets of diff --git a/persistent-postgresql/persistent-postgresql.cabal b/persistent-postgresql/persistent-postgresql.cabal index 39bf8c070..158569aee 100644 --- a/persistent-postgresql/persistent-postgresql.cabal +++ b/persistent-postgresql/persistent-postgresql.cabal @@ -1,5 +1,5 @@ name: persistent-postgresql -version: 2.12.0.0 +version: 2.12.1.0 license: MIT license-file: LICENSE author: Felipe Lessa, Michael Snoyman @@ -16,7 +16,7 @@ extra-source-files: ChangeLog.md library build-depends: base >= 4.9 && < 5 - , persistent >= 2.12 && < 3 + , persistent >= 2.12.1.0 && < 2.13 , aeson >= 1.0 , attoparsec , blaze-builder diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md index 87913f4d3..4d1b76097 100644 --- a/persistent/ChangeLog.md +++ b/persistent/ChangeLog.md @@ -1,5 +1,11 @@ # Changelog for persistent +## 2.12.1.0 + +* [#1226](https://github.com/yesodweb/persistent/pull/1226) + * Expose the `filterClause` and `filterClauseWithValues` functions to support + the `upsertWhere` functionality in `persistent-postgresql`. + ## 2.12.0.2 * [#1123](https://github.com/yesodweb/persistent/pull/1223) @@ -22,10 +28,10 @@ * Added `makeCompatibleInstances` and `makeCompatibleKeyInstances`, TemplateHaskell invocations for auto-generating standalone derivations using `Compatible` and `DerivingVia`. * [#1207](https://github.com/yesodweb/persistent/pull/1207) * @codygman discovered a bug in [issue #1199](https://github.com/yesodweb/persistent/issues/1199) where postgres connections were being returned to the `Pool SqlBackend` in an inconsistent state. - @parsonsmatt debugged the issue and determined that it had something to do with asynchronous exceptions. + @parsonsmatt debugged the issue and determined that it had something to do with asynchronous exceptions. Declaring it to be "out of his pay grade," he ripped the `poolToAcquire` function out and replaced it with `Data.Pool.withResource`, which doesn't exhibit the bug. Fortunately, this doesn't affect the public API, and can be a mere bug release. - * Removed the functions `unsafeAcquireSqlConnFromPool`, `acquireASqlConnFromPool`, and `acquireSqlConnFromPoolWithIsolation`. + * Removed the functions `unsafeAcquireSqlConnFromPool`, `acquireASqlConnFromPool`, and `acquireSqlConnFromPoolWithIsolation`. For a replacement, see `runSqlPoolNoTransaction` and `runSqlPoolWithHooks`. * Renaming values in persistent-template [#1203](https://github.com/yesodweb/persistent/pull/1203) * [#1214](https://github.com/yesodweb/persistent/pull/1214): diff --git a/persistent/Database/Persist/Sql.hs b/persistent/Database/Persist/Sql.hs index 33676da55..5bb716e98 100644 --- a/persistent/Database/Persist/Sql.hs +++ b/persistent/Database/Persist/Sql.hs @@ -13,7 +13,6 @@ module Database.Persist.Sql , deleteWhereCount , updateWhereCount , filterClause - , filterClauseHelper , filterClauseWithVals , FilterTablePrefix (..) , transactionSave @@ -31,13 +30,13 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Reader (ReaderT, ask) import Database.Persist -import Database.Persist.Sql.Types -import Database.Persist.Sql.Types.Internal (IsolationLevel (..)) import Database.Persist.Sql.Class -import Database.Persist.Sql.Run hiding (rawAcquireSqlConn, rawRunSqlPool) -import Database.Persist.Sql.Raw -import Database.Persist.Sql.Migration import Database.Persist.Sql.Internal +import Database.Persist.Sql.Migration +import Database.Persist.Sql.Raw +import Database.Persist.Sql.Run hiding (rawAcquireSqlConn, rawRunSqlPool) +import Database.Persist.Sql.Types +import Database.Persist.Sql.Types.Internal (IsolationLevel(..)) import Database.Persist.Sql.Orphan.PersistQuery import Database.Persist.Sql.Orphan.PersistStore diff --git a/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs b/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs index a593bf4e1..2308ef2ae 100644 --- a/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs +++ b/persistent/Database/Persist/Sql/Orphan/PersistQuery.hs @@ -233,9 +233,21 @@ getFiltsValues conn = snd . filterClauseHelper Nothing False conn OrNullNo data OrNull = OrNullYes | OrNullNo +-- | Used when determining how to prefix a column name in a @WHERE@ clause. +-- +-- @since 2.12.1.0 data FilterTablePrefix - = PrefixTableName - | PrefixExcluded + = PrefixTableName + -- ^ Prefix the column with the table name. This is useful if the column + -- name might be ambiguous. + -- + -- @since 2.12.1.0 + | PrefixExcluded + -- ^ Prefix the column name with the @EXCLUDED@ keyword. This is used with + -- the Postgresql backend when doing @ON CONFLICT DO UPDATE@ clauses - see + -- the documentation on @upsertWhere@ and @upsertManyWhere@. + -- + -- @since 2.12.1.0 filterClauseHelper :: (PersistEntity val) => Maybe FilterTablePrefix -- ^ include table name or PostgresSQL EXCLUDED @@ -397,6 +409,10 @@ filterClauseHelper tablePrefix includeWhere conn orNull filters = showSqlFilter NotIn = " NOT IN " showSqlFilter (BackendSpecificFilter s) = s +-- | Render a @['Filter' record]@ into a 'Text' value suitable for inclusion +-- into a SQL query. +-- +-- @since 2.12.1.0 filterClause :: (PersistEntity val) => Maybe FilterTablePrefix -- ^ include table name or EXCLUDED -> SqlBackend @@ -404,6 +420,11 @@ filterClause :: (PersistEntity val) -> Text filterClause b c = fst . filterClauseHelper b True c OrNullNo +-- | Render a @['Filter' record]@ into a 'Text' value suitable for inclusion +-- into a SQL query, as well as the @['PersistValue']@ to properly fill in the +-- @?@ place holders. +-- +-- @since 2.12.1.0 filterClauseWithVals :: (PersistEntity val) => Maybe FilterTablePrefix -- ^ include table name or EXCLUDED -> SqlBackend @@ -450,4 +471,4 @@ decorateSQLWithLimitOffset nolimit (limit,offset) _ sql = [ sql , lim , off - ] \ No newline at end of file + ] diff --git a/persistent/persistent.cabal b/persistent/persistent.cabal index 26f1c9d27..2719a7983 100644 --- a/persistent/persistent.cabal +++ b/persistent/persistent.cabal @@ -1,5 +1,5 @@ name: persistent -version: 2.12.0.2 +version: 2.12.1.0 license: MIT license-file: LICENSE author: Michael Snoyman