pg-entity 0.0.1.0 → 0.0.2.0

raw patch · 14 files changed

+1611/−581 lines, 14 filesdep +aesondep +containersdep +hedgehogdep −hspecdep −hspec-expectations-lifteddep −hspec-pg-transactdep ~basedep ~bytestringdep ~parsecPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: aeson, containers, hedgehog, mtl, optics-core, tasty, tasty-hunit, text-display, tmp-postgres

Dependencies removed: hspec, hspec-expectations-lifted, hspec-pg-transact

Dependency ranges changed: base, bytestring, parsec, resource-pool, safe-exceptions, template-haskell, text, time, vector

API changes (from Hackage documentation)

Files

• CHANGELOG.md +20/−1
• README.md +18/−8
• pg-entity.cabal +101/−88
• src/Database/PostgreSQL/Entity.hs +324/−95
• src/Database/PostgreSQL/Entity/DBT.hs +118/−55
• src/Database/PostgreSQL/Entity/Internal.hs +128/−28
• src/Database/PostgreSQL/Entity/Internal/BlogPost.hs +98/−49
• src/Database/PostgreSQL/Entity/Internal/QQ.hs +16/−17
• src/Database/PostgreSQL/Entity/Internal/Unsafe.hs +28/−29
• src/Database/PostgreSQL/Entity/Types.hs +163/−58
• test/EntitySpec.hs +235/−121
• test/GenericsSpec.hs +133/−26
• test/Main.hs +31/−6
• test/Utils.hs +198/−0

@@ -1,5 +1,24 @@ # Revision history for Entity -## 0.1.0.0 -- YYYY-mm-dd+## 0.0.2.0 -- 2022-08-27++This is an experimental release++* Add `queryOne_`, which takes no params and returns 0 or 1 results.+* Add `FieldModifiers` deriving option, which takes multiple modifiers:+  * `StripPrefix (prefix :: Symbol)`: You can remove a certain prefix from your field names+  * `CamelTo (separator :: Symbol)` and its variants, `CamelToSnake` and `CamelToKebab`: Transform field names written+  in CamelCase to snake\_case, kebab-case, or with a custom separator.+* Remove redundant metadata about the query nature when logging the query+* Add `selectOneWhereIn` that can match a row's column in a value of user-provided values+* Add `selectOrderBy` to specify a vector of sorting specs (field + sorting keyword) with your select.+* Fix primary key detection in generic deriving+* Remove `withPool'`.+* When using `resource-pool-0.3`, the type of `withPool` reflects the removal of `MonadBaseControl` from the upstream.+* The `prod` Cabal flag is introduced. At this time, it disables the stdout logging of queries+* Add an `upsert` function+* Stop filtering out unknown fields passed to `_where`. PostgreSQL will report them better than we do.++## 0.0.1.0 -- 2021-11-05  * First version. Released on an unsuspecting world.

@@ -1,11 +1,25 @@-# PG-Entity [![CI-badge][CI-badge]][CI-url] [![docs][docs]][docs-url] ![simple-haskell][simple-haskell]+<h1 align="center">+  pg-entity+</h1> +<p align="center">+<a href="https://github.com/tchoutri/pg-entity/actions">+  <img src="https://img.shields.io/github/workflow/status/tchoutri/pg-entity/CI?style=flat-square" alt="CI badge" />+</a>+<a href="https://haskell.org">+  <img src="https://img.shields.io/badge/Made%20in-Haskell-%235e5086?logo=haskell&style=flat-square" alt="made with Haskell"/>+</a>+<a href="https://hackage.haskell.org/package/pg-entity">+  <img src="https://img.shields.io/hackage/v/pg-entity?style=flat-square" alt="Hackage" />+</a>+</p>+ This library is a pleasant layer on top of [postgresql-simple][pg-simple] to safely expand the fields of a table when writing SQL queries.   It aims to be a convenient middle-ground between rigid ORMs and hand-rolled SQL query strings. Here is its philosophy:  * The serialisation/deserialisation part is left to the consumer, so you have to go with your own FromRow/ToRow instances.-  You are encouraged to adopt data types that model your business, rather than restrict yourself within the limits of what+  You are encouraged to adopt data types in your application that model your business domain, rather than restrict yourself within the limits of what   an SQL schema can represent. Use an intermediate Data Access Object (DAO) that can easily be serialised and deserialised   to and from a SQL schema, to and from which you will morph your business data-types. * Illegal states are made harder (but not impossible) to represent. Generic deriving of entities is encouraged, and@@ -43,15 +57,11 @@   - pg-entity-0.0.1.0 ``` -The following GHC versions are supported:--* 8.8-* 8.10-* 9.0+* [List of supported GHC versions](https://github.com/tchoutri/pg-entity/blob/main/pg-entity.cabal#L16)  ## Documentation -This library aims to be thoroughly tested, by the means of Oleg Grerus' [cabal-docspec][docspec]+This library aims to be thoroughly tested, by the means of Oleg Grenrus' [cabal-docspec][docspec] and more traditional tests for database roundtrips.  I aim to produce and maintain a decent documentation, therefore do not hesitate to raise an issue if you feel that

@@ -1,77 +1,78 @@-cabal-version:    3.0-name:             pg-entity-synopsis:         A pleasant PostgreSQL layer+cabal-version:      3.0+name:               pg-entity+synopsis:           A pleasant PostgreSQL layer description:   A PostgreSQL layer to safely expand your SQL queries with a lightweight eDSL.   Read the tutorial at https://tchoutri.github.io/pg-entity/Tutorial-version:          0.0.1.0-homepage:         https://tchoutri.github.io/pg-entity-bug-reports:      https://github.com/tchoutri/pg-entity/issues-author:           Théophile Choutri-maintainer:       Théophile Choutri-category:         Database-license:          MIT-build-type:       Simple-tested-with:      GHC ==8.8.4 || ==8.10.7 || ==9.0.1++version:            0.0.2.0+homepage:           https://tchoutri.github.io/pg-entity+bug-reports:        https://github.com/tchoutri/pg-entity/issues+author:             Théophile Choutri+maintainer:         Théophile Choutri+category:           Database+license:            MIT+build-type:         Simple+tested-with:        GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.4 extra-source-files:-    CHANGELOG.md-    LICENSE.md-    README.md+  CHANGELOG.md+  LICENSE.md+  README.md +flag prod+  description:+    This flag enables features for production usage, namely:+    * Disable logging output++  default:     False+  manual:      True+ source-repository head-  type: git+  type:     git   location: https://github.com/tchoutri/pg-entity  common common-extensions-  default-extensions: AllowAmbiguousTypes -                      ConstraintKinds-                      DataKinds-                      DeriveAnyClass-                      DeriveGeneric-                      DerivingStrategies-                      DerivingVia-                      DisambiguateRecordFields-                      DuplicateRecordFields-                      FlexibleContexts-                      FlexibleInstances-                      GeneralizedNewtypeDeriving-                      InstanceSigs-                      KindSignatures-                      MultiParamTypeClasses-                      NamedFieldPuns-                      OverloadedStrings-                      RankNTypes-                      RecordWildCards-                      ScopedTypeVariables-                      StandaloneDeriving-                      TypeApplications-                      TypeOperators-  default-language: Haskell2010+  default-extensions:+    AllowAmbiguousTypes+    ConstraintKinds+    DataKinds+    DeriveAnyClass+    DeriveGeneric+    DerivingStrategies+    DerivingVia+    DisambiguateRecordFields+    DuplicateRecordFields+    FlexibleContexts+    FlexibleInstances+    GeneralizedNewtypeDeriving+    InstanceSigs+    KindSignatures+    MultiParamTypeClasses+    NamedFieldPuns+    OverloadedLabels+    OverloadedStrings+    RankNTypes+    RecordWildCards+    ScopedTypeVariables+    StandaloneDeriving+    TypeApplications+    TypeOperators +  default-language:   Haskell2010+ common common-ghc-options-  ghc-options: -Wall-               -Wcompat-               -Widentities-               -Wincomplete-record-updates-               -Wincomplete-uni-patterns-               -Wno-unused-do-bind-               -Wno-deprecations-               -Wpartial-fields-               -Wredundant-constraints-               -fhide-source-paths-               -funbox-strict-fields-               -fwrite-ide-info-               -hiedir=.hie-               -haddock+  ghc-options:+    -Wall -Wcompat -Widentities -Wincomplete-record-updates+    -Wincomplete-uni-patterns -Wno-unused-do-bind -Wno-deprecations+    -Wpartial-fields -Wredundant-constraints -fhide-source-paths+    -funbox-strict-fields -fwrite-ide-info -hiedir=.hie -haddock  common common-rts-options-  ghc-options: -rtsopts-               -threaded-               -with-rtsopts=-N+  ghc-options: -rtsopts -threaded -with-rtsopts=-N  library-  import: common-extensions-  import: common-ghc-options+  import:          common-extensions+  import:          common-ghc-options   exposed-modules:     Database.PostgreSQL.Entity     Database.PostgreSQL.Entity.DBT@@ -80,47 +81,59 @@     Database.PostgreSQL.Entity.Internal.QQ     Database.PostgreSQL.Entity.Internal.Unsafe     Database.PostgreSQL.Entity.Types-  hs-source-dirs:-      src++  hs-source-dirs:  src   build-depends:-    , base               >= 4.12 && <= 4.16-    , bytestring        ^>= 0.10-    , colourista        ^>= 0.1-    , monad-control     ^>= 1.0-    , pg-transact       ^>= 0.3-    , postgresql-simple ^>= 0.6-    , resource-pool     ^>= 0.2-    , exceptions        ^>= 0.10-    , parsec            ^>= 3.1.14.0-    , safe-exceptions   ^>= 0.1-    , text              ^>= 1.2-    , text-manipulate   ^>= 0.3-    , template-haskell   >= 2.15.0.0 && <= 2.17.0.0-    , time              ^>= 1.9-    , uuid              ^>= 1.3-    , vector            ^>= 0.12+    , base               >=4.12     && <=4.18+    , bytestring         ^>=0.11+    , colourista         ^>=0.1+    , exceptions         ^>=0.10+    , monad-control      ^>=1.0+    , parsec             ^>=3.1+    , pg-transact        ^>=0.3+    , postgresql-simple  ^>=0.6+    , resource-pool      ^>=0.3+    , safe-exceptions    ^>=0.1+    , template-haskell   >=2.15.0.0 && <=2.18.0.0+    , text               ^>=2.0+    , text-display       ^>=0.0+    , text-manipulate    ^>=0.3+    , time               ^>=1.12+    , uuid               ^>=1.3+    , vector             ^>=0.13 +  if !flag(prod)+    cpp-options: -DPROD+ test-suite entity-test-  import: common-extensions-  import: common-ghc-options-  import: common-rts-options-  type: exitcode-stdio-1.0-  main-is: Main.hs+  import:         common-extensions+  import:         common-ghc-options+  import:         common-rts-options+  type:           exitcode-stdio-1.0+  main-is:        Main.hs   other-modules:     EntitySpec     GenericsSpec-  hs-source-dirs:-      test+    Utils++  hs-source-dirs: test   build-depends:+    , aeson     , base-    , hspec-    , hspec-expectations-lifted-    , hspec-pg-transact == 0.1.0.3+    , containers+    , hedgehog+    , mtl+    , optics-core     , pg-entity     , pg-transact     , postgresql-simple-    , postgresql-simple-migration ^>= 0.1+    , postgresql-simple-migration  ^>=0.1+    , resource-pool+    , safe-exceptions+    , tasty+    , tasty-hunit     , text     , time+    , tmp-postgres     , uuid     , vector

@@ -1,21 +1,19 @@ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE Strict #-}-{-|-  Module      : Database.PostgreSQL.Entity-  Copyright   : © Clément Delafargue, 2018-                  Théophile Choutri, 2021-  License     : MIT-  Maintainer  : theophile@choutri.eu-  Stability   : stable -  A PostgreSQL database layer that does not get in your way.---  See the "Database.PostgreSQL.Entity.Internal.BlogPost" module for an example of a data-type implementing the 'Entity' typeclass.--}+-- |+--  Module      : Database.PostgreSQL.Entity+--  Copyright   : © Clément Delafargue, 2018+--                  Théophile Choutri, 2021+--  License     : MIT+--  Maintainer  : theophile@choutri.eu+--  Stability   : stable+--+--  A PostgreSQL database layer that does not get in your way.+--+--  See the "Database.PostgreSQL.Entity.Internal.BlogPost" module for an example of a data-type implementing the 'Entity' typeclass. module Database.PostgreSQL.Entity-  (-    -- * The /Entity/ Typeclass+  ( -- * The /Entity/ Typeclass     Entity (..)      -- * Associated Types@@ -23,23 +21,31 @@      -- * High-level API     -- $highlevel-    -- ** Selection   , selectById   , selectOneByField   , selectManyByField   , selectWhereNotNull   , selectWhereNull+  , selectOneWhereIn   , joinSelectById+  , joinSelectOneByField+  , selectOrderBy+     -- ** Insertion   , insert+  , insertMany+  , upsert+     -- ** Update   , update   , updateFieldsBy+     -- ** Deletion   , delete   , deleteByField      -- * SQL Combinators API+     -- ** Selection   , _select   , _selectWithFields@@ -47,25 +53,35 @@   , _selectWhere   , _selectWhereNotNull   , _selectWhereNull+  , _selectWhereIn   , _joinSelect   , _innerJoin   , _joinSelectWithFields+  , _joinSelectOneByField+     -- ** Insertion   , _insert+  , _onConflictDoUpdate+     -- ** Update   , _update   , _updateBy   , _updateFields   , _updateFieldsBy+     -- ** Deletion   , _delete   , _deleteWhere-  ) where+  , _orderBy+  , _orderByMany+  )+where  import Control.Monad (void) import Control.Monad.IO.Class (MonadIO) import Data.Foldable (fold)-import Data.Int+import Data.Int (Int64)+import Data.Text.Display (display) import Data.Vector (Vector) import qualified Data.Vector as V import Database.PostgreSQL.Simple (Only (..))@@ -75,7 +91,8 @@ import Database.PostgreSQL.Simple.Types (Query (..)) import Database.PostgreSQL.Transact (DBT) -import Database.PostgreSQL.Entity.DBT (QueryNature (..), execute, query, queryOne, query_)+import Data.Text (Text)+import Database.PostgreSQL.Entity.DBT (QueryNature (..), execute, executeMany, query, queryOne, queryOne_, query_) import Database.PostgreSQL.Entity.Internal import Database.PostgreSQL.Entity.Types @@ -85,8 +102,13 @@ -- >>> :set -XOverloadedLists -- >>> :set -XTypeApplications -- >>> import Database.PostgreSQL.Entity+-- >>> import Database.PostgreSQL.Entity.Types+-- >>> import Database.PostgreSQL.Entity.Internal -- >>> import Database.PostgreSQL.Entity.Internal.BlogPost -- >>> import Database.PostgreSQL.Entity.Internal.QQ+-- >>> import Database.PostgreSQL.Simple.Types (Query (..))+-- >>> import Data.Vector (Vector)+-- >>> import qualified Data.Vector as V  -- $highlevel -- Glossary / Tips’n’Tricks@@ -102,25 +124,33 @@ -- | Select an entity by its primary key. -- -- @since 0.0.1.0-selectById :: forall e value m.-           (Entity e, FromRow e, MonadIO m, ToRow value)-           => value -> DBT m (Maybe e)+selectById ::+  forall e value m.+  (Entity e, FromRow e, MonadIO m, ToRow value) =>+  value ->+  DBT m (Maybe e) selectById value = selectOneByField (primaryKey @e) value  -- | Select precisely __one__ entity by a provided field. -- -- @since 0.0.1.0-selectOneByField :: forall e value m.-                 (Entity e, FromRow e, MonadIO m, ToRow value)-                 => Field -> value -> DBT m (Maybe e)+selectOneByField ::+  forall e value m.+  (Entity e, FromRow e, MonadIO m, ToRow value) =>+  Field ->+  value ->+  DBT m (Maybe e) selectOneByField f value = queryOne Select (_selectWhere @e [f]) value  -- | Select potentially many entities by a provided field. -- -- @since 0.0.1.0-selectManyByField :: forall e value m.-                  (Entity e, FromRow e, MonadIO m, ToRow value)-                  => Field -> value -> DBT m (Vector e)+selectManyByField ::+  forall e value m.+  (Entity e, FromRow e, MonadIO m, ToRow value) =>+  Field ->+  value ->+  DBT m (Vector e) selectManyByField f value = query Select (_selectWhere @e [f]) value  -- | Select statement with a non-null condition@@ -128,9 +158,11 @@ -- See '_selectWhereNotNull' for the generated query. -- -- @since 0.0.1.0-selectWhereNotNull :: forall e m.-                   (Entity e, FromRow e, MonadIO m)-                   => Vector Field -> DBT m (Vector e)+selectWhereNotNull ::+  forall e m.+  (Entity e, FromRow e, MonadIO m) =>+  Vector Field ->+  DBT m (Vector e) selectWhereNotNull fs = query_ Select (_selectWhereNotNull @e fs)  -- | Select statement with a null condition@@ -138,27 +170,96 @@ -- See '_selectWhereNull' for the generated query. -- -- @since 0.0.1.0-selectWhereNull :: forall e m.-                   (Entity e, FromRow e, MonadIO m)-                   => Vector Field -> DBT m (Vector e)+selectWhereNull ::+  forall e m.+  (Entity e, FromRow e, MonadIO m) =>+  Vector Field ->+  DBT m (Vector e) selectWhereNull fs = query_ Select (_selectWhereNull @e fs) +-- | Select statement when for an entity where the field is one of the options passed+--+-- @since 0.0.2.0+selectOneWhereIn ::+  forall e m.+  (Entity e, FromRow e, MonadIO m) =>+  Field ->+  Vector Text ->+  DBT m (Maybe e)+selectOneWhereIn f values = queryOne_ Select (_selectWhereIn @e f values)+ -- | Perform a INNER JOIN between two entities -- -- @since 0.0.1.0-joinSelectById :: forall e1 e2 m.-                (Entity e1, Entity e2, FromRow e1, MonadIO m)-                => DBT m (Vector e1)+joinSelectById ::+  forall e1 e2 m.+  (Entity e1, Entity e2, FromRow e1, MonadIO m) =>+  DBT m (Vector e1) joinSelectById = query_ Select (_joinSelect @e1 @e2) +-- | Perform a @INNER JOIN ON field1 WHERE field2 = value@ between two entities+--+-- @since 0.0.2.0+joinSelectOneByField ::+  forall e1 e2 value m.+  (Entity e1, Entity e2, FromRow e1, MonadIO m, ToField value) =>+  -- | The field over which the two tables will be joined+  Field ->+  -- | The field in the where clause+  Field ->+  -- | The value of the where clause+  value ->+  DBT m (Vector e1)+joinSelectOneByField pivot whereClause value =+  query Select (_joinSelectOneByField @e1 @e2 pivot whereClause) (Only value)++--++-- | Perform a SELECT + ORDER BY query on an entity+--+-- @since 0.0.2.0+selectOrderBy ::+  forall e m.+  (Entity e, FromRow e, MonadIO m) =>+  Vector (Field, SortKeyword) ->+  DBT m (Vector e)+selectOrderBy sortSpec = query_ Select (_select @e <> _orderByMany sortSpec)+ -- | Insert an entity. -- -- @since 0.0.1.0-insert :: forall e values m.-       (Entity e, ToRow values, MonadIO m)-       => values -> DBT m ()+insert ::+  forall e values m.+  (Entity e, ToRow values, MonadIO m) =>+  values ->+  DBT m () insert fs = void $ execute Insert (_insert @e) fs +-- | Insert an entity with a "ON CONFLICT DO UPDATE" clause on the primary key as the conflict target+--+-- @since 0.0.2.0+upsert ::+  forall e values m.+  (Entity e, ToRow values, MonadIO m) =>+  -- | Entity to insert+  values ->+  -- | Fields to replace in case of conflict+  Vector Field ->+  DBT m ()+upsert entity fieldsToReplace = void $ execute Insert (_insert @e <> _onConflictDoUpdate conflictTarget fieldsToReplace) entity+  where+    conflictTarget = V.singleton $ primaryKey @e++-- | Insert multiple rows of an entity.+--+-- @since 0.0.2.0+insertMany ::+  forall e values m.+  (Entity e, ToRow values, MonadIO m) =>+  [values] ->+  DBT m ()+insertMany values = void $ executeMany Insert (_insert @e) values+ -- | Update an entity. -- -- The Id of the entity is put at the end of the query automatically through the use of 'UpdateRow'.@@ -168,9 +269,11 @@ -- > update @Author newAuthor -- -- @since 0.0.1.0-update :: forall e newValue m.-       (Entity e, ToRow newValue, MonadIO m)-       => newValue -> DBT m ()+update ::+  forall e newValue m.+  (Entity e, ToRow newValue, MonadIO m) =>+  newValue ->+  DBT m () update fs = void $ execute Update (_update @e) (UpdateRow fs)  -- | Update rows of an entity matching the given value@@ -182,20 +285,26 @@ -- > updateFieldsBy @Author [[field| name |]] ([field| name |], oldName) (Only newName) -- -- @since 0.0.1.0-updateFieldsBy :: forall e v1 v2 m.-           (Entity e, MonadIO m, ToRow v2, ToField v1)-           => Vector Field -- ^ Fields to change-           -> (Field, v1)  -- ^ Field on which to match and its value-           -> v2    -- ^ New values of those fields-           -> DBT m Int64+updateFieldsBy ::+  forall e v1 v2 m.+  (Entity e, MonadIO m, ToRow v2, ToField v1) =>+  -- | Fields to change+  Vector Field ->+  -- | Field on which to match and its value+  (Field, v1) ->+  -- | New values of those fields+  v2 ->+  DBT m Int64 updateFieldsBy fs (f, oldValue) newValue = execute Update (_updateFieldsBy @e fs f) (toRow newValue ++ toRow (Only oldValue))  -- | Delete an entity according to its primary key. -- -- @since 0.0.1.0-delete :: forall e value m.-       (Entity e, ToRow value, MonadIO m)-       => value -> DBT m ()+delete ::+  forall e value m.+  (Entity e, ToRow value, MonadIO m) =>+  value ->+  DBT m () delete value = deleteByField @e [primaryKey @e] value  -- | Delete rows according to the given fields@@ -205,9 +314,12 @@ -- > deleteByField @BlogPost [[field| title |]] (Only "Echoes from the other world") -- -- @since 0.0.1.0-deleteByField :: forall e values m.-       (Entity e, ToRow values, MonadIO m)-       => Vector Field -> values -> DBT m ()+deleteByField ::+  forall e values m.+  (Entity e, ToRow values, MonadIO m) =>+  Vector Field ->+  values ->+  DBT m () deleteByField fs values = void $ execute Delete (_deleteWhere @e fs) values  -- * SQL combinators API@@ -228,20 +340,21 @@ -- __Examples__ -- -- >>> _selectWithFields @BlogPost [ [field| blogpost_id |], [field| created_at |] ]--- "SELECT blogposts.\"blogpost_id\", blogposts.\"created_at\" FROM \"blogposts\""+-- "SELECT \"blogposts\".\"blogpost_id\", \"blogposts\".\"created_at\" FROM \"\"blogposts\"\"" -- -- @since 0.0.1.0 _selectWithFields :: forall e. Entity e => Vector Field -> Query _selectWithFields fs = textToQuery $ "SELECT " <> expandQualifiedFields' fs tn <> " FROM " <> quoteName tn-  where tn = tableName @e+  where+    tn = getTableName @e  -- | Produce a WHERE clause, given a vector of fields. -- -- It is most useful composed with a '_select' or '_delete', which is why these two combinations have their dedicated functions, -- but the user is free to compose their own queries. ----- The 'Entity' constraint is required for '_where' in order to get any type annotation that was given in the schema, as well as to--- filter out unexisting fields.+-- The 'Entity' constraint is required for '_where' in order to get any type annotation that was given in the schema.+-- Fields that do not exist in the Entity will be kept so that PostgreSQL can report the error. -- -- __Examples__ --@@ -249,15 +362,13 @@ -- "SELECT blogposts.\"blogpost_id\", blogposts.\"author_id\", blogposts.\"uuid_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\" FROM \"blogposts\" WHERE \"blogpost_id\" = ?" -- -- >>> _select @BlogPost <> _where @BlogPost [ [field| uuid_list |] ]--- "SELECT blogposts.\"blogpost_id\", blogposts.\"author_id\", blogposts.\"uuid_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\" FROM \"blogposts\" WHERE \"uuid_list\" = ?::uuid[]"+-- "SELECT blogposts.\"blogpost_id\", blogposts.\"author_id\", blogposts.\"uuid_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\" FROM \"blogposts\" WHERE \"uuid_list\" = ?" -- -- @since 0.0.1.0-_where :: forall e. Entity e => Vector Field -> Query+_where :: Vector Field -> Query _where fs' = textToQuery $ " WHERE " <> clauseFields   where-    fieldNames = fmap fieldName fs'-    fs = V.filter (\f -> fieldName f `elem` fieldNames) (fields @e)-    clauseFields = fold $ intercalateVector " AND " (fmap placeholder fs)+    clauseFields = fold $ intercalateVector " AND " (fmap placeholder fs')  -- | Produce a SELECT statement for a given entity and fields. --@@ -266,9 +377,12 @@ -- >>> _selectWhere @BlogPost [ [field| author_id |] ] -- "SELECT blogposts.\"blogpost_id\", blogposts.\"author_id\", blogposts.\"uuid_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\" FROM \"blogposts\" WHERE \"author_id\" = ?" --+-- >>> _selectWhere @BlogPost [ [field| author_id |], [field| title |]]+-- "SELECT blogposts.\"blogpost_id\", blogposts.\"author_id\", blogposts.\"uuid_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\" FROM \"blogposts\" WHERE \"author_id\" = ? AND \"title\" = ?"+-- -- @since 0.0.1.0 _selectWhere :: forall e. Entity e => Vector Field -> Query-_selectWhere fs = _select @e <> _where @e fs+_selectWhere fs = _select @e <> _where fs  -- | Produce a SELECT statement where the provided fields are checked for being non-null. -- r@@ -289,6 +403,15 @@ _selectWhereNull :: forall e. Entity e => Vector Field -> Query _selectWhereNull fs = _select @e <> textToQuery (" WHERE " <> isNull fs) +-- | Produce a SELECT statement where the given field is checked aginst the provided array of values .+--+-- >>> _selectWhereIn @BlogPost [field| title |] [ "Unnamed", "Mordred's Song" ]+-- "SELECT blogposts.\"blogpost_id\", blogposts.\"author_id\", blogposts.\"uuid_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\" FROM \"blogposts\" WHERE \"title\" IN ('Unnamed', 'Mordred''s Song')"+--+-- @since 0.0.2.0+_selectWhereIn :: forall e. Entity e => Field -> Vector Text -> Query+_selectWhereIn f values = _select @e <> textToQuery (" WHERE " <> isIn f values)+ -- | Produce a "SELECT FROM" over two entities. -- -- __Examples__@@ -298,10 +421,15 @@ -- -- @since 0.0.1.0 _joinSelect :: forall e1 e2. (Entity e1, Entity e2) => Query-_joinSelect = textToQuery $ "SELECT " <> expandQualifiedFields @e1 <> ", "-                                    <> expandQualifiedFields @e2 <>-                           " FROM " <> getTableName @e1-                           <> queryToText (_innerJoin @e2 (primaryKey @e2))+_joinSelect =+  textToQuery $+    "SELECT "+      <> expandQualifiedFields @e1+      <> ", "+      <> expandQualifiedFields @e2+      <> " FROM "+      <> getTableName @e1+      <> queryToText (_innerJoin @e2 (primaryKey @e2))  -- | Produce a "INNER JOIN … USING(…)" fragment. --@@ -312,8 +440,13 @@ -- -- @since 0.0.1.0 _innerJoin :: forall e. (Entity e) => Field -> Query-_innerJoin f = textToQuery $ " INNER JOIN " <> getTableName @e-                          <> " USING(" <> fieldName f <> ")"+_innerJoin f =+  textToQuery $+    " INNER JOIN "+      <> getTableName @e+      <> " USING("+      <> fieldName f+      <> ")"  -- | Produce a "SELECT [table1_fields, table2_fields] FROM table1 INNER JOIN table2 USING(table2_pk)" statement. -- The primary is used as the join point between the two tables.@@ -321,26 +454,67 @@ -- __Examples__ -- -- >>> _joinSelectWithFields @BlogPost @Author [ [field| title |] ] [ [field| name |] ]--- "SELECT blogposts.\"title\", authors.\"name\" FROM \"blogposts\" INNER JOIN \"authors\" USING(author_id)"+-- "SELECT \"blogposts\".\"title\", \"authors\".\"name\" FROM \"blogposts\" INNER JOIN \"authors\" USING(author_id)" -- -- @since 0.0.1.0-_joinSelectWithFields :: forall e1 e2. (Entity e1, Entity e2)-                   => Vector Field -> Vector Field -> Query+_joinSelectWithFields ::+  forall e1 e2.+  (Entity e1, Entity e2) =>+  Vector Field ->+  Vector Field ->+  Query _joinSelectWithFields fs1 fs2 =-  textToQuery $ "SELECT " <> expandQualifiedFields' fs1 tn1-    <> ", " <> expandQualifiedFields' fs2 tn2-    <> " FROM " <> getTableName @e1-    <> queryToText (_innerJoin @e2 (primaryKey @e2))+  textToQuery $+    "SELECT "+      <> expandQualifiedFields' fs1 tn1+      <> ", "+      <> expandQualifiedFields' fs2 tn2+      <> " FROM "+      <> getTableName @e1+      <> queryToText (_innerJoin @e2 (primaryKey @e2))   where-    tn1 = tableName @e1-    tn2 = tableName @e2+    tn1 = getTableName @e1+    tn2 = getTableName @e2 +-- | Produce a "SELECT FROM" over two entities.+--+-- __Examples__+--+-- >>> _joinSelectOneByField @BlogPost @Author [field| author_id |] [field| name |] :: Query+-- "SELECT blogposts.\"blogpost_id\", blogposts.\"author_id\", blogposts.\"uuid_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\" FROM \"blogposts\" INNER JOIN \"authors\" ON \"blogposts\".\"author_id\" = \"authors\".\"author_id\" WHERE authors.\"name\" = ?"+--+-- @since 0.0.2.0+_joinSelectOneByField ::+  forall e1 e2.+  (Entity e1, Entity e2) =>+  Field ->+  Field ->+  Query+_joinSelectOneByField pivotField whereField =+  textToQuery $+    "SELECT "+      <> expandQualifiedFields @e1+      <> " FROM "+      <> (getTableName @e1)+      <> " INNER JOIN "+      <> getTableName @e2+      <> " ON "+      <> (getTableName @e1)+      <> "."+      <> getFieldName pivotField+      <> " = "+      <> (getTableName @e2)+      <> "."+      <> getFieldName pivotField+      <> " WHERE "+      <> placeholder' @e2 whereField+ -- | Produce an INSERT statement for the given entity. -- -- __Examples__ -- -- >>> _insert @BlogPost--- "INSERT INTO \"blogposts\" (\"blogpost_id\", \"author_id\", \"uuid_list\", \"title\", \"content\", \"created_at\") VALUES (?, ?, ?::uuid[], ?, ?, ?)"+-- "INSERT INTO \"blogposts\" (\"blogpost_id\", \"author_id\", \"uuid_list\", \"title\", \"content\", \"created_at\") VALUES (?, ?, ?, ?, ?, ?)" -- -- @since 0.0.1.0 _insert :: forall e. Entity e => Query@@ -349,6 +523,29 @@     fs = inParens (expandFields @e)     ps = inParens (generatePlaceholders $ fields @e) +-- | Produce a "ON CONFLICT (target) DO UPDATE SET …" statement.+--+-- __Examples__+--+-- >>> _onConflictDoUpdate [[field| blogpost_id |]] [ [field| title |], [field| content |]]+-- " ON CONFLICT (blogpost_id) DO UPDATE SET title = EXCLUDED.title, content = EXCLUDED.content"+--+-- >>> _onConflictDoUpdate [[field| blogpost_id |], [field| author_id |]] [ [field| title |], [field| content |]]+-- " ON CONFLICT (blogpost_id, author_id) DO UPDATE SET title = EXCLUDED.title, content = EXCLUDED.content"+--+-- >>> _insert @BlogPost <> _onConflictDoUpdate [[field| blogpost_id |]] [ [field| title |], [field| content |]]+-- "INSERT INTO \"blogposts\" (\"blogpost_id\", \"author_id\", \"uuid_list\", \"title\", \"content\", \"created_at\") VALUES (?, ?, ?, ?, ?, ?) ON CONFLICT (blogpost_id) DO UPDATE SET title = EXCLUDED.title, content = EXCLUDED.content"+--+-- @since 0.0.2.0+_onConflictDoUpdate :: Vector Field -> Vector Field -> Query+_onConflictDoUpdate conflictTarget fieldsToReplace =+  textToQuery $ " ON CONFLICT (" <> targetNames <> ") DO UPDATE SET " <> replacedFields+  where+    targetNames = fold $ intercalateVector ", " (fmap fieldName conflictTarget)+    replacedFields = fold $ intercalateVector ", " (fmap (replaceField . fieldName) fieldsToReplace)+    replaceField :: Text -> Text+    replaceField f = f <> " = EXCLUDED." <> f+ -- | Produce an UPDATE statement for the given entity by primary key -- -- __Examples__@@ -357,10 +554,9 @@ -- "UPDATE \"authors\" SET (\"name\", \"created_at\") = ROW(?, ?) WHERE \"author_id\" = ?" -- -- >>> _update @BlogPost--- "UPDATE \"blogposts\" SET (\"author_id\", \"uuid_list\", \"title\", \"content\", \"created_at\") = ROW(?, ?::uuid[], ?, ?, ?) WHERE \"blogpost_id\" = ?"+-- "UPDATE \"blogposts\" SET (\"author_id\", \"uuid_list\", \"title\", \"content\", \"created_at\") = ROW(?, ?, ?, ?, ?) WHERE \"blogpost_id\" = ?" -- -- @since 0.0.1.0- _update :: forall e. Entity e => Query _update = _updateBy @e (primaryKey @e) @@ -393,19 +589,30 @@ -- "UPDATE \"blogposts\" SET (\"author_id\", \"title\") = ROW(?, ?) WHERE \"title\" = ?" -- -- @since 0.0.1.0-_updateFieldsBy :: forall e. Entity e-                => Vector Field -- ^ Field names to update-                -> Field        -- ^ Field on which to match-                -> Query-_updateFieldsBy fs' f = textToQuery (-    "UPDATE " <> getTableName @e-              <> " SET " <> updatedFields <> " = " <> newValues)-              <> _where @e [f]+_updateFieldsBy ::+  forall e.+  Entity e =>+  -- | Field names to update+  Vector Field ->+  -- | Field on which to match+  Field ->+  Query+_updateFieldsBy fs' f =+  textToQuery+    ( "UPDATE "+        <> getTableName @e+        <> " SET "+        <> updatedFields+        <> " = "+        <> newValues+    )+    <> _where [f]   where     fs = V.filter (/= (primaryKey @e)) fs'     newValues = "ROW" <> inParens (generatePlaceholders fs)-    updatedFields = inParens $-      V.foldl1' (\element acc -> element <> ", " <> acc) (quoteName . fieldName <$> fs)+    updatedFields =+      inParens $+        V.foldl1' (\element acc -> element <> ", " <> acc) (quoteName . fieldName <$> fs)  -- | Produce a DELETE statement for the given entity, with a match on the Primary Key --@@ -416,15 +623,37 @@ -- -- @since 0.0.1.0 _delete :: forall e. Entity e => Query-_delete = textToQuery ("DELETE FROM " <> getTableName @e) <> _where @e [primaryKey @e]+_delete = textToQuery ("DELETE FROM " <> getTableName @e) <> _where [primaryKey @e]  -- | Produce a DELETE statement for the given entity and fields -- -- __Examples__ -- -- >>> _deleteWhere @BlogPost [[field| title |], [field| created_at |]]--- "DELETE FROM blogposts WHERE \"title\" = ? AND \"created_at\" = ?"+-- "DELETE FROM \"blogposts\" WHERE \"title\" = ? AND \"created_at\" = ?" -- -- @since 0.0.1.0 _deleteWhere :: forall e. Entity e => Vector Field -> Query-_deleteWhere fs = textToQuery ("DELETE FROM " <> (tableName @e)) <> _where @e fs+_deleteWhere fs = textToQuery ("DELETE FROM " <> (getTableName @e)) <> _where fs++-- | Produce an ORDER BY clause with one field and a sorting keyword+--+-- __Examples__+--+-- >>> _orderBy ([field| title |], ASC)+-- " ORDER BY \"title\" ASC"+--+-- @since 0.0.2.0+_orderBy :: (Field, SortKeyword) -> Query+_orderBy (f, sort) = textToQuery (" ORDER BY " <> quoteName (fieldName f) <> " " <> display sort)++-- | Produce an ORDER BY clause with many fields and sorting keywords+--+-- __Examples__+--+-- >>> _orderByMany (V.fromList [([field| title |], ASC), ([field| created_at |], DESC)])+-- " ORDER BY \"title\" ASC, \"created_at\" DESC"+--+-- @since 0.0.2.0+_orderByMany :: Vector (Field, SortKeyword) -> Query+_orderByMany sortExpressions = textToQuery $ " ORDER BY " <> fold (intercalateVector ", " $ fmap renderSortExpression sortExpressions)

@@ -1,47 +1,55 @@-{-|-  Module      : Database.PostgreSQL.Entity.DBT-  Copyright   : © Clément Delafargue, 2018-                  Théophile Choutri, 2021-  License     : MIT-  Maintainer  : theophile@choutri.eu-  Stability   : stable+{-# LANGUAGE CPP #-} -  The 'Database.PostgreSQL.Transact.DBT' plumbing module to handle database queries and pools--}+-- |+--  Module      : Database.PostgreSQL.Entity.DBT+--  Copyright   : © Clément Delafargue, 2018+--                  Théophile Choutri, 2021+--  License     : MIT+--  Maintainer  : theophile@choutri.eu+--  Stability   : stable+--+--  The 'Database.PostgreSQL.Transact.DBT' plumbing module to handle database queries and pools module Database.PostgreSQL.Entity.DBT   ( mkPool   , withPool-  , withPool'   , execute+  , executeMany   , query   , query_   , queryOne-  , QueryNature(..)-  ) where+  , queryOne_+  , QueryNature (..)+  )+where +#ifdef PROD+#else import Colourista.IO (cyanMessage, redMessage, yellowMessage)+import Data.ByteString (ByteString)+import Data.Text.Encoding (decodeUtf8)+import qualified Database.PostgreSQL.Simple as Simple+#endif+ import Control.Monad.IO.Class-import Control.Monad.Trans.Control (MonadBaseControl) import Data.Int import Data.Maybe (listToMaybe) import Data.Pool (Pool, createPool, withResource)-import Data.Text.Encoding (decodeUtf8) import Data.Time (NominalDiffTime) import Data.Vector (Vector) import qualified Data.Vector as V -import Control.Monad.Catch (Exception, MonadCatch, try) import Database.PostgreSQL.Simple as PG (ConnectInfo, Connection, FromRow, Query, ToRow, close, connect) import qualified Database.PostgreSQL.Transact as PGT  -- | Create a Pool Connection with the appropriate parameters -- -- @since 0.0.1.0-mkPool :: ConnectInfo     -- Database access information-       -> Int             -- Number of sub-pools-       -> NominalDiffTime -- Allowed timeout-       -> Int             -- Number of connections-       -> IO (Pool Connection)+mkPool ::+  ConnectInfo -> -- Database access information+  Int -> -- Number of sub-pools+  NominalDiffTime -> -- Allowed timeout+  Int -> -- Number of connections+  IO (Pool Connection) mkPool connectInfo subPools timeout connections =   createPool (connect connectInfo) close subPools timeout connections @@ -62,68 +70,123 @@ -- See the code in the @example/@ directory on GitHub -- -- @since 0.0.1.0-withPool :: (MonadBaseControl IO m)-         => Pool Connection -> PGT.DBT m a -> m a-withPool pool action = withResource pool $ PGT.runDBTSerializable action---- | Run a DBT action while handling errors as Exceptions.------ This function wraps the DBT actions in a 'try', so that exceptions--- raised will be converted to the Left branch of the Either.------ @since 0.0.1.0-withPool' :: forall errorType result m-          . (Exception errorType, MonadCatch m, MonadBaseControl IO m)-         => Pool Connection-         -> PGT.DBT m result-         -> m (Either errorType result)-withPool' pool action = try $ withPool pool action+#if MIN_VERSION_resource_pool(0,3,0)+withPool :: (MonadIO m) => Pool Connection -> PGT.DBT IO a -> m a+withPool pool action = liftIO $ withResource pool (\conn -> PGT.runDBTSerializable action conn)+#else+withPool :: (MonadBaseControl IO m) => Pool Connection -> PGT.DBT m a -> m a+withPool pool action = withResource pool (\conn -> PGT.runDBTSerializable action conn)+#endif  -- | Query wrapper that returns a 'Vector' of results -- -- @since 0.0.1.0-query :: (ToRow params, FromRow result, MonadIO m)-          => QueryNature -> Query -> params -> PGT.DBT m (Vector result)+query ::+  (ToRow params, FromRow result, MonadIO m) =>+  QueryNature ->+  Query ->+  params ->+  PGT.DBT m (Vector result) query queryNature q params = do   logQueryFormat queryNature q params   V.fromList <$> PGT.query q params +-- | Query wrapper that returns a 'Vector' of results and does not take an argument+--+-- @since 0.0.1.0+query_ ::+  (FromRow result, MonadIO m) =>+  QueryNature ->+  Query ->+  PGT.DBT m (Vector result)+query_ queryNature q = do+  logQueryFormat queryNature q ()+  V.fromList <$> PGT.query_ q+ -- | Query wrapper that returns one result. -- -- @since 0.0.1.0-queryOne :: (ToRow params, FromRow result, MonadIO m)-         => QueryNature -> Query -> params -> PGT.DBT m (Maybe result)+queryOne ::+  (ToRow params, FromRow result, MonadIO m) =>+  QueryNature ->+  Query ->+  params ->+  PGT.DBT m (Maybe result) queryOne queryNature q params = do   logQueryFormat queryNature q params-  result <- PGT.query q params-  pure $ listToMaybe result+  listToMaybe <$> PGT.query q params --- | Query wrapper that returns a 'Vector' of results and does not take an argument ----- @since 0.0.1.0-query_ :: (FromRow result, MonadIO m)-       => QueryNature -> Query -> PGT.DBT m (Vector result)-query_ queryNature q = do++-- | Query wrapper that returns one result and does not take an argument+--+-- @since 0.0.2.0+queryOne_ ::+  (FromRow result, MonadIO m) =>+  QueryNature ->+  Query ->+  PGT.DBT m (Maybe result)+queryOne_ queryNature q = do   logQueryFormat queryNature q ()-  V.fromList <$> PGT.query_ q+  listToMaybe <$> PGT.query_ q  -- | Query wrapper for SQL statements which do not return. -- -- @since 0.0.1.0-execute :: (ToRow params, MonadIO m)-        => QueryNature -> Query -> params -> PGT.DBT m Int64+execute ::+  (ToRow params, MonadIO m) =>+  QueryNature ->+  Query ->+  params ->+  PGT.DBT m Int64 execute queryNature q params = do   logQueryFormat queryNature q params   PGT.execute q params -logQueryFormat :: (ToRow params, MonadIO m) => QueryNature -> Query -> params -> PGT.DBT m ()+-- | Query wrapper for SQL statements that operate on multiple rows which do not return.+--+-- @since 0.0.2.0+executeMany ::+  (ToRow params, MonadIO m) =>+  QueryNature ->+  Query ->+  [params] ->+  PGT.DBT m Int64+executeMany queryNature q params = do+  logQueryFormatMany queryNature q params+  PGT.executeMany q params++#ifdef PROD+logQueryFormat :: (Monad m) => QueryNature -> Query -> params -> PGT.DBT m ()+logQueryFormat _ _ _ = pure ()+#else+logQueryFormat :: (ToRow params, MonadIO m)+               => QueryNature -> Query -> params -> PGT.DBT m () logQueryFormat queryNature q params = do   msg <- PGT.formatQuery q params   case queryNature of-    Select -> liftIO $ cyanMessage   $ "[SELECT] " <> decodeUtf8 msg-    Update -> liftIO $ yellowMessage $ "[UPDATE] " <> decodeUtf8 msg-    Insert -> liftIO $ yellowMessage $ "[INSERT] " <> decodeUtf8 msg-    Delete -> liftIO $ redMessage    $ "[DELETE] " <> decodeUtf8 msg+    Select -> liftIO $ cyanMessage   $ decodeUtf8 msg+    Update -> liftIO $ yellowMessage $ decodeUtf8 msg+    Insert -> liftIO $ yellowMessage $ decodeUtf8 msg+    Delete -> liftIO $ redMessage    $ decodeUtf8 msg+#endif++#ifdef PROD+logQueryFormatMany :: (Monad m) => QueryNature -> Query -> [params] -> PGT.DBT m ()+logQueryFormatMany _ _ _ = pure ()+#else+logQueryFormatMany :: (ToRow params, MonadIO m) => QueryNature -> Query -> [params] -> PGT.DBT m ()+logQueryFormatMany queryNature q params = do+  msg <- formatMany q params+  case queryNature of+    Select -> liftIO $ cyanMessage   $ decodeUtf8 msg+    Update -> liftIO $ yellowMessage $ decodeUtf8 msg+    Insert -> liftIO $ yellowMessage $ decodeUtf8 msg+    Delete -> liftIO $ redMessage    $ decodeUtf8 msg++formatMany :: (ToRow q, MonadIO m) => Query -> [q] -> PGT.DBT m ByteString+formatMany q xs = PGT.getConnection >>= \conn -> liftIO $ Simple.formatMany conn q xs+#endif  -- | This sum type is given to the 'query', 'queryOne' and 'execute' functions to help -- with logging.

@@ -1,33 +1,42 @@ {-# LANGUAGE Strict #-}-{-|-  Module      : Database.PostgreSQL.Entity.Internal-  Copyright   : © Clément Delafargue, 2018-                  Théophile Choutri, 2021-  License     : MIT-  Maintainer  : theophile@choutri.eu-  Stability   : stable -  Internal helpers used to implement the high-level API and SQL combinators.--  You can re-use those building blocks freely to create your own wrappers.--}+-- |+--  Module      : Database.PostgreSQL.Entity.Internal+--  Copyright   : © Clément Delafargue, 2018+--                  Théophile Choutri, 2021+--  License     : MIT+--  Maintainer  : theophile@choutri.eu+--  Stability   : stable+--+--  Internal helpers used to implement the high-level API and SQL combinators.+--+--  You can re-use those building blocks freely to create your own wrappers. module Database.PostgreSQL.Entity.Internal   ( -- * Helpers     isNotNull   , isNull+  , isIn   , inParens   , quoteName+  , literal   , getTableName+  , getFieldName+  , getPrimaryKey+  , prefix   , expandFields   , expandQualifiedFields   , expandQualifiedFields'+  , qualifyField   , qualifyFields   , placeholder+  , placeholder'   , generatePlaceholders   , textToQuery   , queryToText   , intercalateVector-  ) where+  , renderSortExpression+  )+where  import Data.String (fromString) import Data.Text (Text, unpack)@@ -37,6 +46,8 @@ import Database.PostgreSQL.Simple.Types (Query (..))  import Data.Foldable (fold)+import qualified Data.Text as T+import Data.Text.Display (display) import Database.PostgreSQL.Entity.Internal.Unsafe (Field (Field)) import Database.PostgreSQL.Entity.Types @@ -45,6 +56,7 @@ -- >>> :set -XOverloadedLists -- >>> :set -XTypeApplications -- >>> import Database.PostgreSQL.Entity+-- >>> import Database.PostgreSQL.Entity.Types -- >>> import Database.PostgreSQL.Entity.Internal.BlogPost -- >>> import Database.PostgreSQL.Entity.Internal.QQ -- >>> import Database.PostgreSQL.Entity.Internal.Unsafe@@ -71,15 +83,54 @@ quoteName :: Text -> Text quoteName n = "\"" <> n <> "\"" +-- | Wrap the given text between single quotes, for literal text in an SQL query.+--+-- __Examples__+--+-- >>> literal "meow."+-- "'meow.'"+--+-- @since 0.0.2.0+literal :: Text -> Text+literal n = "\'" <> escapeSingleQuotes n <> "\'"+  where+    escapeSingleQuotes x = T.replace "'" "''" x+ -- | Safe getter that quotes a table name -- -- __Examples__ -- -- >>> getTableName @Author -- "\"authors\""+-- >>> getTableName @Tags+-- "public.\"tags\""+--+-- @since 0.0.1.0 getTableName :: forall e. Entity e => Text-getTableName = quoteName (tableName @e)+getTableName = prefix (schema @e) <> quoteName (tableName @e) +-- | Safe getter that quotes a table's primary key+--+-- __Examples__+--+-- >>> getPrimaryKey @Author+-- "\"author_id\""+-- >>> getPrimaryKey @Tags+-- "\"category\""+--+-- @since 0.0.2.0+getPrimaryKey :: forall e. Entity e => Text+getPrimaryKey = getFieldName $ primaryKey @e++prefix :: Maybe Text -> Text+prefix = maybe "" (<> ".")++-- | Accessor to the name of a field, with quotation.+--+-- >>> getFieldName ([field| author_id |])+-- "\"author_id\""+--+-- @since 0.0.2.0 getFieldName :: Field -> Text getFieldName = quoteName . fieldName @@ -103,9 +154,9 @@ -- -- @since 0.0.1.0 expandQualifiedFields :: forall e. Entity e => Text-expandQualifiedFields = expandQualifiedFields' (fields @e) prefix+expandQualifiedFields = expandQualifiedFields' (fields @e) prefixName   where-    prefix = tableName @e+    prefixName = tableName @e  -- | Produce a comma-separated list of an entity's 'fields', qualified with an arbitrary prefix --@@ -116,16 +167,31 @@ -- -- @since 0.0.1.0 expandQualifiedFields' :: Vector Field -> Text -> Text-expandQualifiedFields' fs prefix = V.foldl1' (\element acc -> element <> ", " <> acc) fs'+expandQualifiedFields' fs prefixName = V.foldl1' (\element acc -> element <> ", " <> acc) fs'   where-    fs' = fieldName <$> qualifyFields prefix fs+    fs' = fieldName <$> qualifyFields prefixName fs +--+ -- | Take a prefix and a vector of fields, and qualifies each field with the prefix -- -- __Examples__ --+-- >>> qualifyField @Author [field| name |]+-- "authors.\"name\""+--+-- @since 0.0.2.0+qualifyField :: forall e. Entity e => Field -> Text+qualifyField f = (\(Field fName _) -> p <> "." <> quoteName fName) f+  where+    p = tableName @e++-- | Take a prefix and a vector of fields, and qualifies each field with the prefix+--+-- __Examples__+-- -- >>> qualifyFields "legacy" (fields @BlogPost)--- [Field "legacy.\"blogpost_id\"" Nothing,Field "legacy.\"author_id\"" Nothing,Field "legacy.\"uuid_list\"" (Just "uuid[]"),Field "legacy.\"title\"" Nothing,Field "legacy.\"content\"" Nothing,Field "legacy.\"created_at\"" Nothing]+-- [Field "legacy.\"blogpost_id\"" Nothing,Field "legacy.\"author_id\"" Nothing,Field "legacy.\"uuid_list\"" Nothing,Field "legacy.\"title\"" Nothing,Field "legacy.\"content\"" Nothing,Field "legacy.\"created_at\"" Nothing] -- -- @since 0.0.1.0 qualifyFields :: Text -> Vector Field -> Vector Field@@ -138,17 +204,32 @@ -- >>> placeholder [field| id |] -- "\"id\" = ?" ----- >>> placeholder $ [field| ids :: uuid[] |]--- "\"ids\" = ?::uuid[]"+-- >>> placeholder $ [field| ids |]+-- "\"ids\" = ?" -- -- >>> fmap placeholder $ fields @BlogPost--- ["\"blogpost_id\" = ?","\"author_id\" = ?","\"uuid_list\" = ?::uuid[]","\"title\" = ?","\"content\" = ?","\"created_at\" = ?"]+-- ["\"blogpost_id\" = ?","\"author_id\" = ?","\"uuid_list\" = ?","\"title\" = ?","\"content\" = ?","\"created_at\" = ?"] -- -- @since 0.0.1.0 placeholder :: Field -> Text-placeholder (Field f Nothing)  = quoteName f <> " = ?"+placeholder (Field f Nothing) = quoteName f <> " = ?" placeholder (Field f (Just t)) = quoteName f <> " = ?::" <> t +-- | Produce a placeholder of the form @table.\"field\" = ?@ with an optional type annotation.+--+-- __Examples__+--+-- >>> placeholder' @BlogPost [field| id |]+-- "blogposts.\"id\" = ?"+--+-- >>> placeholder' @BlogPost $ [field| ids |]+-- "blogposts.\"ids\" = ?"+--+-- @since 0.0.2.0+placeholder' :: forall e. Entity e => Field -> Text+placeholder' f@(Field _ (Just t)) = qualifyField @e f <> " = ?::" <> t+placeholder' f = qualifyField @e f <> " = ?"+ -- | Generate an appropriate number of “?” placeholders given a vector of fields. -- -- Used to generate INSERT queries.@@ -156,7 +237,7 @@ -- __Examples__ -- -- >>> generatePlaceholders $ fields @BlogPost--- "?, ?, ?::uuid[], ?, ?, ?"+-- "?, ?, ?, ?, ?, ?" -- -- @since 0.0.1.0 generatePlaceholders :: Vector Field -> Text@@ -194,6 +275,12 @@     fieldNames = fmap fieldName fs'     process f = quoteName f <> " IS NULL" +isIn :: Field -> Vector Text -> Text+isIn f values = process f <> " IN (" <> fold (intercalateVector ", " vals) <> ")"+  where+    vals = fmap literal values+    process f' = quoteName $ fieldName f'+ -- | Since the 'Query' type has an 'IsString' instance, the process of converting from 'Text' to 'String' to 'Query' is -- factored into this function --@@ -225,10 +312,23 @@ -- -- @since 0.0.1.0 intercalateVector :: Text -> Vector Text -> Vector Text-intercalateVector sep vt | V.null vt = vt-                         | otherwise = V.cons x (go xs)+intercalateVector sep vt+  | V.null vt = vt+  | otherwise = V.cons x (go xs)   where-    (x,xs) = (V.head vt, V.tail vt)+    (x, xs) = (V.head vt, V.tail vt)     go :: Vector Text -> Vector Text-    go ys | V.null ys = ys-          | otherwise = V.cons sep (V.cons (V.head ys) (go (V.tail ys)))+    go ys+      | V.null ys = ys+      | otherwise = V.cons sep (V.cons (V.head ys) (go (V.tail ys)))++-- |+--+-- __Examples__+--+-- >>> renderSortExpression ([field| title |], ASC)+-- "\"title\" ASC"+--+-- @since 0.0.2.0+renderSortExpression :: (Field, SortKeyword) -> Text+renderSortExpression (f, sort) = (quoteName . fieldName) f <> " " <> display sort

@@ -1,20 +1,20 @@ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE StrictData #-}-{-|-  Module      : Database.PostgreSQL.Entity.Internal.BlogPost-  Copyright   : © Clément Delafargue, 2018-                  Théophile Choutri, 2021-                  Koz Ross, 2021-  License     : MIT-  Maintainer  : theophile@choutri.eu-  Stability   : stable -  Adapted from Clément Delafargue's [Yet Another Unsafe DB Layer](https://tech.fretlink.com/yet-another-unsafe-db-layer/)-  article.--  The models described in this module are used throughout the library's tests and docspecs.--}+-- |+--  Module      : Database.PostgreSQL.Entity.Internal.BlogPost+--  Copyright   : © Clément Delafargue, 2018+--                  Théophile Choutri, 2021+--                  Koz Ross, 2021+--  License     : MIT+--  Maintainer  : theophile@choutri.eu+--  Stability   : stable+--+--  Adapted from Clément Delafargue's [Yet Another Unsafe DB Layer](https://tech.fretlink.com/yet-another-unsafe-db-layer/)+--  article.+--+--  The models described in this module are used throughout the library's tests and docspecs. module Database.PostgreSQL.Entity.Internal.BlogPost where  import Data.Text (Text)@@ -22,80 +22,129 @@ import Data.UUID (UUID) import Data.Vector (Vector) import Database.PostgreSQL.Simple.FromField (FromField)-import Database.PostgreSQL.Simple.FromRow (FromRow)-import Database.PostgreSQL.Simple.ToField (ToField)+import Database.PostgreSQL.Simple.FromRow (FromRow (..))+import Database.PostgreSQL.Simple.ToField (Action (..), ToField (..)) import Database.PostgreSQL.Simple.ToRow (ToRow) import Database.PostgreSQL.Transact (DBT) import GHC.Generics (Generic) import GHC.OverloadedLabels (IsLabel (..)) import GHC.Records (HasField (..)) -import Database.PostgreSQL.Entity (insert)+import Data.ByteString.Builder (byteString, char8)+import qualified Data.List as List+import qualified Data.Vector as Vector+import Database.PostgreSQL.Entity (Field, insert, insertMany, upsert) import Database.PostgreSQL.Entity.Internal.QQ (field) import Database.PostgreSQL.Entity.Types (Entity (..), GenericEntity, PrimaryKey, TableName)  -- | Wrapper around the UUID type-newtype AuthorId-  = AuthorId { getAuthorId :: UUID }-  deriving (Eq, FromField, Show, ToField)+newtype AuthorId = AuthorId {getAuthorId :: UUID}+  deriving+    (Eq, FromField, Ord, Show, ToField)     via UUID  -- | Author data-type-data Author-  = Author { authorId  :: AuthorId-           , name      :: Text-           , createdAt :: UTCTime-           }-  deriving stock (Eq, Generic, Show)+data Author = Author+  { authorId :: AuthorId+  , name :: Text+  , createdAt :: UTCTime+  }+  deriving stock (Eq, Generic, Ord, Show)   deriving anyclass (FromRow, ToRow)-  deriving (Entity)+  deriving+    (Entity)     via (GenericEntity '[PrimaryKey "author_id", TableName "authors"] Author)  instance HasField x Author a => IsLabel x (Author -> a) where   fromLabel = getField @x  -- | Wrapper around the UUID type-newtype BlogPostId-  = BlogPostId { getBlogPostId :: UUID }-  deriving (Eq, FromField, Show, ToField)+newtype BlogPostId = BlogPostId {getBlogPostId :: UUID}+  deriving+    (Eq, FromField, Ord, Show, ToField)     via UUID +newtype UUIDList = UUIDList {getUUIDList :: Vector UUID}+  deriving stock (Generic, Show)+  deriving+    (Eq, FromField, Ord)+    via Vector UUID++instance ToField UUIDList where+  toField (UUIDList vec) =+    if Vector.null vec+      then Plain (byteString "'{}'")+      else+        Many $+          Plain (byteString "ARRAY[")+            : (List.intersperse (Plain (char8 ',')) . fmap toField $ Vector.toList vec)+            ++ [Plain (char8 ']')]+            ++ [Plain (byteString " :: uuid[]")]+ -- | The BlogPost data-type. Look at its 'Entity' instance declaration for how to handle -- a "uuid[]" PostgreSQL type.-data BlogPost-  = BlogPost { blogPostId :: BlogPostId-               -- ^ Primary key-             , authorId   :: AuthorId-               -- ^ Foreign keys, for which we need an explicit type annotation-             , uuidList   :: Vector UUID-               -- ^ A type that will need an explicit type annotation in the schema-             , title      :: Text-             , content    :: Text-             , createdAt  :: UTCTime-             }-  deriving stock (Eq, Generic, Show)+data BlogPost = BlogPost+  { blogPostId :: BlogPostId+  -- ^ Primary key+  , authorId :: AuthorId+  -- ^ Foreign keys, for which we need an explicit type annotation+  , uuidList :: UUIDList+  -- ^ A type that will need an explicit type annotation in the schema+  , title :: Text+  , content :: Text+  , createdAt :: UTCTime+  }+  deriving stock (Eq, Generic, Ord, Show)   deriving anyclass (FromRow, ToRow)  instance HasField x BlogPost a => IsLabel x (BlogPost -> a) where   fromLabel = getField @x  instance Entity BlogPost where-  tableName  = "blogposts"+  tableName = "blogposts"   primaryKey = [field| blogpost_id |]-  fields = [ [field| blogpost_id |]-           , [field| author_id |]-           , [field| uuid_list :: uuid[] |]-           , [field| title |]-           , [field| content |]-           , [field| created_at |]-           ]+  fields =+    [ [field| blogpost_id |]+    , [field| author_id |]+    , [field| uuid_list |]+    , [field| title |]+    , [field| content |]+    , [field| created_at |]+    ]  -- | A specialisation of the 'Database.PostgreSQL.Entity.insert' function. -- @insertBlogPost = insert \@BlogPost@ insertBlogPost :: BlogPost -> DBT IO () insertBlogPost = insert @BlogPost +upsertBlogPost :: BlogPost -> Vector Field -> DBT IO ()+upsertBlogPost = upsert @BlogPost++-- | A function to insert many blogposts at once.+bulkInsertBlogPosts :: [BlogPost] -> DBT IO ()+bulkInsertBlogPosts = insertMany @BlogPost+ -- | A specialisation of the 'Database.PostgreSQL.Entity.insert function. -- @insertAuthor = insert \@Author@ insertAuthor :: Author -> DBT IO () insertAuthor = insert @Author++--++-- | A function to insert many authors at once.+bulkInsertAuthors :: [Author] -> DBT IO ()+bulkInsertAuthors = insertMany @Author++data Tags = Tags+  { category :: Text+  , labels :: [Text]+  }++instance Entity Tags where+  tableName = "tags"+  schema = Just "public"+  primaryKey = [field| category |]+  fields =+    [ [field| category |]+    , [field| labels |]+    ]

@@ -1,17 +1,16 @@ {-# LANGUAGE TemplateHaskell #-} -{-|- Module     : Database.PostgreSQL.Entity.Internal.QQ- Copyright  : © Koz Ross, 2021- License    : MIT- Maintainer : koz.ross@retro-freedom.nz- Stability  : Experimental-- A quasi-quoter for 'Field's, supporting optional types.-- There is little reason to import this module directly; instead, import- 'Database.PostgreSQL.Entity', which re-exports the 'field' quasiquoter.--}+-- |+-- Module     : Database.PostgreSQL.Entity.Internal.QQ+-- Copyright  : © Koz Ross, 2021+-- License    : MIT+-- Maintainer : koz.ross@retro-freedom.nz+-- Stability  : Experimental+--+-- A quasi-quoter for 'Field's, supporting optional types.+--+-- There is little reason to import this module directly; instead, import+-- 'Database.PostgreSQL.Entity', which re-exports the 'field' quasiquoter. module Database.PostgreSQL.Entity.Internal.QQ (field) where  import Data.Text (Text, pack)@@ -44,9 +43,9 @@  fieldExp :: String -> Q Exp fieldExp input = case parse fieldParser "Expression" input of-  Left err               -> fail . show $ err-  Right (name, Nothing)  -> [e| Field $(lift name) Nothing |]-  Right (name, Just typ) -> [e| Field $(lift name) (Just $(lift typ)) |]+  Left err -> fail . show $ err+  Right (name, Nothing) -> [e|Field $(lift name) Nothing|]+  Right (name, Just typ) -> [e|Field $(lift name) (Just $(lift typ))|]  errorFieldPat :: String -> Q Pat errorFieldPat _ = fail "Cannot use 'field' in a pattern context."@@ -70,13 +69,13 @@           typ <- manyTill anyChar (try space)           case typ of             [] -> fail "Cannot have an empty type."-            _  -> pure (pack name, Just . pack $ typ)+            _ -> pure (pack name, Just . pack $ typ)     noType :: Parsec String () (Text, Maybe Text)     noType = do       name <- manyTill anyChar (try space)       case name of         [] -> fail "Cannot have an empty field name."-        _  -> pure (pack name, Nothing)+        _ -> pure (pack name, Nothing)  errorFieldType :: String -> Q Type errorFieldType _ = fail "Cannot use 'field' in a type context."

@@ -1,31 +1,30 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}-{-|-  Module      : Database.PostgreSQL.Entity.Internal.Unsafe-  Copyright   : © Clément Delafargue, 2018-                  Théophile Choutri, 2021-                  Koz Ross, 2021-  License     : MIT-  Maintainer  : theophile@choutri.eu-  Stability   : Experimental -  Contains the internals of several key types.--  = Note--  By using these directly, you run the risk of violating internal invariants,-  or making representational changes in incompatible ways. This API is not-  stable, and is not subject to the PVP. Use at your own risk--  If at all possible, instead use the API provided by-  'Database.PostgreSQL.Entity.Types'.---}+-- |+--  Module      : Database.PostgreSQL.Entity.Internal.Unsafe+--  Copyright   : © Clément Delafargue, 2018+--                  Théophile Choutri, 2021+--                  Koz Ross, 2021+--  License     : MIT+--  Maintainer  : theophile@choutri.eu+--  Stability   : Experimental+--+--  Contains the internals of several key types.+--+--  = Note+--+--  By using these directly, you run the risk of violating internal invariants,+--  or making representational changes in incompatible ways. This API is not+--  stable, and is not subject to the PVP. Use at your own risk+--+--  If at all possible, instead use the API provided by+--  'Database.PostgreSQL.Entity.Types'. module Database.PostgreSQL.Entity.Internal.Unsafe-  (-    Field (..)-  ) where+  ( Field (..)+  )+where  import Data.Kind import Data.String@@ -39,13 +38,13 @@   = Field Text (Maybe Text)   deriving stock (Eq, Show) -{-| Using the Overloaded String syntax for Field names is forbidden.--}+-- | Using the Overloaded String syntax for Field names is forbidden. instance ForbiddenIsString => IsString Field where   fromString = error "You cannot pass a field as a string. Please use the `field` quasi-quoter instead."  type family ForbiddenIsString :: Constraint where-  ForbiddenIsString = TypeError-    ( 'Text "🚫 You cannot pass a Field name as a string." ':$$:-      'Text "Please use the `field` quasi-quoter instead."-    )+  ForbiddenIsString =+    TypeError+      ( 'Text "🚫 You cannot pass a Field name as a string."+          ':$$: 'Text "Please use the `field` quasi-quoter instead."+      )

@@ -1,21 +1,19 @@-{-|-  Module      : Database.PostgreSQL.Entity.Types-  Copyright   : © Clément Delafargue, 2018-                  Théophile Choutri, 2021-  License     : MIT-  Maintainer  : theophile@choutri.eu-  Stability   : stable--  Types and classes---} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}++-- |+--  Module      : Database.PostgreSQL.Entity.Types+--  Copyright   : © Clément Delafargue, 2018+--                  Théophile Choutri, 2021+--  License     : MIT+--  Maintainer  : theophile@choutri.eu+--  Stability   : stable+--+--  Types and classes module Database.PostgreSQL.Entity.Types-  (-    -- * The /Entity/ Typeclass+  ( -- * The /Entity/ Typeclass     Entity (..)      -- * Associated Types@@ -23,25 +21,39 @@   , field   , fieldName   , fieldType-  , UpdateRow(..)+  , UpdateRow (..)+  , SortKeyword (..)      -- * Generics-  , Options(..)+  , Options (..)   , defaultEntityOptions      -- * DerivingVia Options-  , GenericEntity(..)-  , EntityOptions(..)+  , GenericEntity (..)+  , EntityOptions (..)   , PrimaryKey+  , Schema   , TableName-  ) where+  , FieldModifiers+  , TextModifier (..)+  , StripPrefix+  , CamelTo+  , CamelToSnake+  , CamelToKebab+  )+where +import Data.Char import Data.Kind+import Data.Maybe import Data.Proxy-import Data.Text (Text, pack)+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Display (Display, ShowInstance (..)) import qualified Data.Text.Manipulate as T import Data.Vector (Vector) import qualified Data.Vector as V+import qualified Data.Vector as Vector import Database.PostgreSQL.Entity.Internal.QQ (field) import Database.PostgreSQL.Entity.Internal.Unsafe (Field (Field)) import Database.PostgreSQL.Simple.ToRow (ToRow (..))@@ -75,12 +87,23 @@   tableName :: Text   default tableName :: (GetTableName (Rep e)) => Text   tableName = getTableName @(Rep e) defaultEntityOptions++  -- | The name of the schema; will be appended to the table name: schema."tablename"+  schema :: Maybe Text+  schema = Nothing+   -- | The name of the primary key for the table.   primaryKey :: Field   default primaryKey :: (GetFields (Rep e)) => Field-  primaryKey = Field (primMod name) typ-    where primMod = primaryKeyModifier defaultEntityOptions-          Field name typ = V.head $ getField @(Rep e) defaultEntityOptions+  primaryKey = newPrimaryKey+    where+      primMod = primaryKeyModifiers defaultEntityOptions+      fs = getField @(Rep e) defaultEntityOptions+      newPrimaryKey =+        case Vector.find (\(Field name _type) -> name == primMod name) fs of+          Nothing -> Field (primMod "") Nothing+          Just f -> f+   -- | The fields of the table.   fields :: Vector Field   default fields :: (GetFields (Rep e)) => Vector Field@@ -90,19 +113,19 @@ class GetTableName (e :: Type -> Type) where   getTableName :: Options -> Text -instance (TypeError ('Text "You can't derive Entity for a void type")) => GetTableName V1 where+instance (TypeError ( 'Text "You can't derive Entity for a void type")) => GetTableName V1 where   getTableName _opts = error "You can't derive Entity for a void type" -instance (TypeError ('Text "You can't derive Entity for a unit type")) => GetTableName U1 where+instance (TypeError ( 'Text "You can't derive Entity for a unit type")) => GetTableName U1 where   getTableName _opts = error "You can't derive Entity for a unit type" -instance (TypeError ('Text "You can't derive Entity for a sum type")) => GetTableName (e :+: f) where+instance (TypeError ( 'Text "You can't derive Entity for a sum type")) => GetTableName (e :+: f) where   getTableName _opts = error "You can't derive Entity for a sum type" -instance (TypeError ('Text "You can't derive an Entity for a type constructor's field")) => GetTableName (K1 i c) where+instance (TypeError ( 'Text "You can't derive an Entity for a type constructor's field")) => GetTableName (K1 i c) where   getTableName _opts = error "You can't derive Entity for a type constructor's field" -instance (TypeError ('Text "You don't have to derive GetTableName for a product type")) => GetTableName (e :*: f) where+instance (TypeError ( 'Text "You don't have to derive GetTableName for a product type")) => GetTableName (e :*: f) where   getTableName _opts = error "You don't have to derive GetTableName for a product type"  instance GetTableName e => GetTableName (M1 C _1 e) where@@ -111,24 +134,26 @@ instance GetTableName e => GetTableName (M1 S _1 e) where   getTableName opts = getTableName @e opts -instance (KnownSymbol name)-    => GetTableName (M1 D ('MetaData name _1 _2 _3) e) where-  getTableName Options{tableNameModifier} = tableNameModifier $ pack $ symbolVal (Proxy :: Proxy name)+instance+  (KnownSymbol name) =>+  GetTableName (M1 D ( 'MetaData name _1 _2 _3) e)+  where+  getTableName Options{tableNameModifiers, fieldModifiers} = tableNameModifiers $ fieldModifiers $ T.pack $ symbolVal (Proxy :: Proxy name)  -- The sub-class that fetches the table fields class GetFields (e :: Type -> Type) where   getField :: Options -> Vector Field -instance (TypeError ('Text "You can't derive Entity for a void type")) => GetFields V1 where+instance (TypeError ( 'Text "You can't derive Entity for a void type")) => GetFields V1 where   getField _opts = error "You can't derive Entity for a void type" -instance (TypeError ('Text "You can't derive Entity for a unit type")) => GetFields U1 where+instance (TypeError ( 'Text "You can't derive Entity for a unit type")) => GetFields U1 where   getField _opts = error "You can't derive Entity for a unit type" -instance (TypeError ('Text "You can't derive Entity for a sum type")) => GetFields (e :+: f) where+instance (TypeError ( 'Text "You can't derive Entity for a sum type")) => GetFields (e :+: f) where   getField _opts = error "You can't derive Entity for a sum type" -instance (TypeError ('Text "You can't derive Entity for a a type constructor's field")) => GetFields (K1 i c) where+instance (TypeError ( 'Text "You can't derive Entity for a a type constructor's field")) => GetFields (K1 i c) where   getField _opts = error "You can't derive Entity for a type constructor's field"  instance (GetFields e, GetFields f) => GetFields (e :*: f) where@@ -137,36 +162,50 @@ instance GetFields e => GetFields (M1 C _1 e) where   getField opts = getField @e opts -instance GetFields e => GetFields (M1 D ('MetaData _1 _2 _3 _4) e) where+instance GetFields e => GetFields (M1 D ( 'MetaData _1 _2 _3 _4) e) where   getField opts = getField @e opts -instance (KnownSymbol name) => GetFields (M1 S ('MetaSel ('Just name) _1 _2 _3) _4) where-  getField Options{fieldModifier} = V.singleton $ Field fieldName' Nothing-    where fieldName' = fieldModifier $ pack $ symbolVal (Proxy @name)+instance (KnownSymbol name) => GetFields (M1 S ( 'MetaSel ( 'Just name) _1 _2 _3) _4) where+  getField Options{fieldModifiers} = V.singleton $ Field fieldName' Nothing+    where+      fieldName' = fieldModifiers $ T.pack $ symbolVal (Proxy @name)  -- Deriving Via machinery -newtype GenericEntity t e-  = GenericEntity { getGenericEntity :: e }+newtype GenericEntity t e = GenericEntity {getGenericEntity :: e}  instance (EntityOptions t, GetTableName (Rep e), GetFields (Rep e)) => Entity (GenericEntity t e) where   tableName = getTableName @(Rep e) (entityOptions @t) -  primaryKey = Field (primMod name) typ-    where primMod = primaryKeyModifier defaultEntityOptions-          Field name typ = V.head $ getField @(Rep e) (entityOptions @t)+  schema = schemaModifier (entityOptions @t) +  primaryKey = newPrimaryKey+    where+      primMod = primaryKeyModifiers (entityOptions @t)+      fs = getField @(Rep e) (entityOptions @t)+      newPrimaryKey =+        case Vector.find (\(Field name _type) -> name == primMod name) fs of+          Nothing -> Field (primMod "") Nothing+          Just f -> f+   fields = getField @(Rep e) (entityOptions @t)  -- | Term-level options-data Options-  = Options { tableNameModifier  :: Text -> Text-            , primaryKeyModifier :: Text -> Text-            , fieldModifier      :: Text -> Text-            }+data Options = Options+  { tableNameModifiers :: Text -> Text+  , schemaModifier :: Maybe Text+  , primaryKeyModifiers :: Text -> Text+  , fieldModifiers :: Text -> Text+  }  defaultEntityOptions :: Options-defaultEntityOptions = Options T.toSnake T.toSnake T.toSnake+defaultEntityOptions =+  Options+    { tableNameModifiers = T.toSnake+    , schemaModifier = Nothing+    , primaryKeyModifiers = T.toSnake+    , fieldModifiers = T.toSnake+    }  -- | Type-level options for Deriving Via class EntityOptions xs where@@ -176,24 +215,84 @@   entityOptions = defaultEntityOptions  instance (GetName name, EntityOptions xs) => EntityOptions (TableName name ': xs) where-  entityOptions = (entityOptions @xs){tableNameModifier = const (getName @name)}+  entityOptions = (entityOptions @xs){tableNameModifiers = const (getName @name)}  instance (GetName name, EntityOptions xs) => EntityOptions (PrimaryKey name ': xs) where-  entityOptions = (entityOptions @xs){primaryKeyModifier = const (getName @name)}+  entityOptions = (entityOptions @xs){primaryKeyModifiers = const (getName @name)} -data TableName t+instance (TextModifier mods, EntityOptions xs) => EntityOptions (FieldModifiers mods ': xs) where+  entityOptions = (entityOptions @xs){fieldModifiers = getTextModifier @mods} -data PrimaryKey t+instance (GetName name, EntityOptions xs) => EntityOptions (Schema name ': xs) where+  entityOptions = (entityOptions @xs){schemaModifier = Just $ getName @name} +data TableName (t :: Symbol)++data PrimaryKey (t :: Symbol)++data Schema (t :: Symbol)++-- | Contains a list of 'TextModifiers' modifiers+data FieldModifiers ms++-- | 'TextModifier' to remove a certain prefix from the fields+data StripPrefix (prefix :: Symbol)++-- | 'FieldModifier' taking a separator Char when transforming from CamelCase.+data CamelTo (separator :: Symbol)++-- | CamelCase to snake_case+type CamelToSnake = CamelTo "_"++-- | CamelCase to kebab-case+type CamelToKebab = CamelTo "-"++-- | The modifiers that you can apply to the fields:+--+-- * 'StripPrefix'+-- * 'CamelTo', and its variations+--   * 'CamelToSnake'+--   * 'CamelToKebab'+class TextModifier t where+  getTextModifier :: Text -> Text++--  No modifier+instance TextModifier '[] where+  getTextModifier = id++-- How we can have multiple modifiers chained+instance (TextModifier x, TextModifier xs) => TextModifier (x ': xs) where+  getTextModifier = getTextModifier @xs . getTextModifier @x++instance (KnownSymbol prefix) => TextModifier (StripPrefix prefix) where+  getTextModifier fld = fromMaybe fld (T.stripPrefix prefixToStrip fld)+    where+      prefixToStrip = T.pack $ symbolVal (Proxy @prefix)++instance (KnownSymbol separator, NonEmptyText separator) => TextModifier (CamelTo separator) where+  getTextModifier fld = T.pack $ camelTo2 char (T.unpack fld)+    where+      char :: Char+      char = head $ symbolVal (Proxy @separator)+      camelTo2 :: Char -> String -> String+      camelTo2 c text = map toLower . go2 $ go1 text+        where+          go1 "" = ""+          go1 (x : u : l : xs) | isUpper u && isLower l = x : c : u : l : go1 xs+          go1 (x : xs) = x : go1 xs+          go2 "" = ""+          go2 (l : u : xs) | isLower l && isUpper u = l : c : u : go2 xs+          go2 (x : xs) = x : go2 xs+ class GetName name where   getName :: Text  instance (KnownSymbol name, NonEmptyText name) => GetName name where-  getName = pack (symbolVal (Proxy @name))+  getName = T.pack (symbolVal (Proxy @name))  type family NonEmptyText (xs :: Symbol) :: Constraint where-  NonEmptyText "" = TypeError ('Text "User-provided string cannot be empty!")-  NonEmptyText _  = ()+  NonEmptyText "" = TypeError ( 'Text "User-provided string cannot be empty!")+  NonEmptyText _ = ()  -- | Get the name of a field. --@@ -211,11 +310,17 @@ -- since it appears in the WHERE clause. -- -- @since 0.0.1.0-newtype UpdateRow a-  = UpdateRow { getUpdate :: a }+newtype UpdateRow a = UpdateRow {getUpdate :: a}   deriving stock (Eq, Show)   deriving newtype (Entity)  instance ToRow a => ToRow (UpdateRow a) where   toRow = (drop <> take) 1 . toRow . getUpdate +-- |+-- @since 0.0.2.0+data SortKeyword = ASC | DESC+  deriving stock (Eq, Show)+  deriving+    (Display)+    via ShowInstance SortKeyword

@@ -9,136 +9,250 @@ import Data.Text (Text) import qualified Data.UUID as UUID import qualified Data.Vector as V-import Database.PostgreSQL.Simple (Connection, Only (Only))-import Database.PostgreSQL.Simple.Migration (MigrationCommand (MigrationDirectory, MigrationInitialization),-                                             runMigrations)+import Database.PostgreSQL.Entity+  ( delete+  , deleteByField+  , joinSelectOneByField+  , selectById+  , selectManyByField+  , selectOneByField+  , selectOneWhereIn+  , selectOrderBy+  , selectWhereNotNull+  , selectWhereNull+  , update+  , updateFieldsBy+  , _joinSelectWithFields+  , _where+  )+import Database.PostgreSQL.Entity.DBT (QueryNature (..), query)+import Database.PostgreSQL.Entity.Internal.BlogPost+  ( Author (..)+  , AuthorId (..)+  , BlogPost (..)+  , bulkInsertAuthors+  , bulkInsertBlogPosts+  , insertAuthor+  , insertBlogPost+  , upsertBlogPost+  )+import Database.PostgreSQL.Simple (Only (Only)) import Database.PostgreSQL.Transact (DBT)-import Test.Hspec (Spec)-import Test.Hspec.DB (describeDB, itDB)-import Test.Hspec.Expectations.Lifted (shouldBe, shouldMatchList, shouldReturn) -import Database.PostgreSQL.Entity (_joinSelectWithFields, delete, deleteByField, selectById, selectManyByField,-                                   selectOneByField, selectWhereNotNull, selectWhereNull, update, updateFieldsBy)-import Database.PostgreSQL.Entity.DBT (QueryNature (..), query_)-import Database.PostgreSQL.Entity.Internal.BlogPost (Author (..), AuthorId (..), BlogPost (..), BlogPostId (BlogPostId),-                                                     insertAuthor, insertBlogPost)-import Database.PostgreSQL.Entity.Internal.QQ (field)+import Data.Maybe (fromJust)+import qualified Data.Set as S+import qualified Data.Set as Set+import Data.Vector (Vector)+import Database.PostgreSQL.Entity.Types+import Optics.Core+import Test.Tasty+import Utils+import qualified Utils as U -author1 :: Author-author1 =-  let authorId = AuthorId (read "74c3fa0e-79e4-11eb-8792-5405db82c3cd")-      name = "Jamie Reynolds"-      createdAt = read "2021-02-28 17:30:13 UTC"-   in Author{..}+spec :: TestM TestTree+spec =+  testThese+    "Entity Tests"+    [ testThis "Select blog post by title" selectBlogPostByTitle+    , testThis "Select blog posts by null and non-null condition" selectByNullAndNonNull+    , testThis "Select multiple blog posts by author id" selectManyByAuthorId+    , testThis "Delete blog posts" deleteBlogPosts+    , testThis "Get all the article titles by author name" getAllTitlesByAuthorName+    , testThis "Change the name of an author" changeAuthorName+    , testThis "Select a row when the value of title is in an array of possible values" selectWhereIn+    , testThis "SELECT ORDER BY yields the appropriate results" testSelectOrderBy+    , testThis "select blog posts by author's name" selectBlogpostsByAuthorName+    , testThis "Insert many blog posts" insertManyBlogPosts+    , testThis "Upsert a blog post" testUpsertBlogPost+    ] -author2 :: Author-author2 =-  let authorId = AuthorId (read "bc97c16c-7b83-11eb-83e5-5405db82c3cd")-      name = "Hansi Kürsch"-      createdAt = read "2021-02-28 17:30:17 UTC"-   in Author{..}+selectBlogPostByTitle :: TestM ()+selectBlogPostByTitle = do+  author <- liftDB $ instantiateRandomAuthor randomAuthorTemplate+  blogPost <- liftDB $ instantiateRandomBlogPost randomBlogPostTemplate{generateAuthorId = pure (author ^. #authorId)}+  result <- liftDB $ selectOneByField @BlogPost [field| title |] (Only (blogPost ^. #title))+  U.assertEqual result (Just blogPost) -author3 :: Author-author3 =-  let authorId = AuthorId (read "3aa9232e-7f6d-11eb-823f-5405db82c3cd")-      name = "Johnson McElroy"-      createdAt = read "2021-02-28 17:31:39 UTC"-   in Author{..}+selectByNullAndNonNull :: TestM ()+selectByNullAndNonNull = do+  author <- liftDB $ instantiateRandomAuthor randomAuthorTemplate -blogPost1 :: BlogPost-blogPost1 =-  let blogPostId = BlogPostId (read "55b3821a-79e4-11eb-ad18-5405db82c3cd")-      authorId   = #authorId author1-      uuidList   = [read "4401d848-7b40-11eb-b148-5405db82c3cd", read "4bbf0786-7b40-11eb-b1d9-5405db82c3cd"]-      title      = "Echoes from the other world"-      content    = "Send out a sound\nFor the wood between the worlds\nGently repeat\nAs the boundaries start to swirl"-      createdAt  = read "2021-02-28 17:48:15 UTC"-  in BlogPost{..}+  liftDB $ instantiateRandomBlogPost randomBlogPostTemplate{generateAuthorId = pure (author ^. #authorId)}+  liftDB $ instantiateRandomBlogPost randomBlogPostTemplate{generateAuthorId = pure (author ^. #authorId)}+  liftDB $ instantiateRandomBlogPost randomBlogPostTemplate{generateAuthorId = pure (author ^. #authorId)}+  liftDB $ instantiateRandomBlogPost randomBlogPostTemplate{generateAuthorId = pure (author ^. #authorId)} -blogPost2 :: BlogPost-blogPost2 =-  let blogPostId = BlogPostId (read "a8df9980-79fb-11eb-a061-5405db82c3cd")-      authorId   = #authorId author2-      uuidList   = [read "4401d848-7b40-11eb-b148-5405db82c3cd", read "4bbf0786-7b40-11eb-b1d9-5405db82c3cd"]-      title      = "A Past and Future Secret"-      content    = "Oh, I haven't been here for a while\nIn blindness and decay\nThe circle's been closed, now"-      createdAt  = read "2021-02-28 20:33:25 UTC"-  in BlogPost{..}+  result <- liftDB $ selectWhereNotNull @BlogPost [[field| author_id |], [field| title |]]+  U.assertEqual True (not . null $ result)+  result1 <- liftDB $ selectWhereNull @BlogPost [[field| author_id |], [field| content |]]+  U.assertEqual 0 (V.length result1) -blogPost3 :: BlogPost-blogPost3 =-  let blogPostId = BlogPostId (read "1a032938-79fc-11eb-b1ec-5405db82c3cd")-      authorId   = #authorId author2-      uuidList   = [read "4401d848-7b40-11eb-b148-5405db82c3cd", read "4bbf0786-7b40-11eb-b1d9-5405db82c3cd"]-      title      = "The Script for my requiem"-      content    = "[…]"-      createdAt  = read "2021-02-28 21:23:25 UTC"-  in BlogPost{..}+selectManyByAuthorId :: TestM ()+selectManyByAuthorId = do+  author <- liftDB $ instantiateRandomAuthor randomAuthorTemplate -blogPost4 :: BlogPost-blogPost4 =-  let blogPostId = BlogPostId (read "1e1e6dac-79fc-11eb-b6a6-5405db82c3cd")-      authorId   = #authorId author2-      uuidList   = [read "4401d848-7b40-11eb-b148-5405db82c3cd", read "4bbf0786-7b40-11eb-b1d9-5405db82c3cd"]-      title      = "Mordred's Song"-      content    = "[…]"-      createdAt  = read "2021-02-28 21:24:35 UTC"-  in BlogPost{..}+  blogPost4 <- liftDB $ instantiateRandomBlogPost randomBlogPostTemplate{generateAuthorId = pure (author ^. #authorId)}+  blogPost2 <- liftDB $ instantiateRandomBlogPost randomBlogPostTemplate{generateAuthorId = pure (author ^. #authorId)}+  blogPost3 <- liftDB $ instantiateRandomBlogPost randomBlogPostTemplate{generateAuthorId = pure (author ^. #authorId)}+  result <- liftDB $ selectManyByField @BlogPost [field| author_id |] $ Only (#authorId blogPost4)+  U.assertEqual (Set.fromList [blogPost2, blogPost3, blogPost4]) (Set.fromList $ V.toList result) +deleteBlogPosts :: TestM ()+deleteBlogPosts = do+  author <- liftDB $ instantiateRandomAuthor randomAuthorTemplate -migrate :: Connection -> IO ()-migrate conn = void $ runMigrations False conn [MigrationInitialization, MigrationDirectory "./test/migrations"]+  blogPost1 <- liftDB $ instantiateRandomBlogPost randomBlogPostTemplate{generateTitle = pure "Echoes from the other world", generateAuthorId = pure (author ^. #authorId)}+  blogPost2 <- liftDB $ instantiateRandomBlogPost randomBlogPostTemplate{generateAuthorId = pure (author ^. #authorId)}+  liftDB $ delete @BlogPost (Only (blogPostId blogPost2))+  result <- liftDB $ selectManyByField @BlogPost [field| blogpost_id |] $ Only (#blogPostId blogPost2)+  U.assertEqual 0 (V.length result) -spec :: Spec-spec = describeDB migrate "Entity DB " $ do-  itDB "Insert authors" $ do-    insertAuthor author1-    insertAuthor author2-    insertAuthor author3-  itDB "Insert blog posts" $ do-    insertBlogPost blogPost1-    insertBlogPost blogPost2-    insertBlogPost blogPost3-    insertBlogPost blogPost4-    result <- selectById $ Only (#blogPostId blogPost1)-    result `shouldBe` Just blogPost1-  itDB "Select blog post by title" $ do-    selectOneByField @BlogPost [field| title |] (Only ("A Past and Future Secret" :: Text))-      `shouldReturn` Just blogPost2-  itDB "Select all blog posts by non-null condition" $ do-    result <- selectWhereNotNull @BlogPost [[field| author_id |], [field| title |]]-    V.toList result `shouldMatchList` [blogPost1, blogPost2, blogPost3, blogPost4]-  itDB "Select no blog post by null condition" $ do-    result <- selectWhereNull @BlogPost [[field| author_id |], [field| content |]]-    V.length result `shouldBe` 0-  itDB "Select multiple blog posts by author id" $ do-    result <- selectManyByField @BlogPost [field| author_id |] $ Only (#authorId blogPost4)-    V.toList result `shouldMatchList` [blogPost2, blogPost3, blogPost4]-  itDB "Delete a blog post" $ do-    delete @BlogPost (Only (blogPostId blogPost2))-    result <- selectManyByField @BlogPost [field| blogpost_id |] $ Only (#blogPostId blogPost2)-    V.length result `shouldBe` 0-  itDB "Delete a blog post by title" $ do-    deleteByField @BlogPost [[field| title |]] (Only @Text "Echoes from the other world")-    result <- selectManyByField @BlogPost [field| title |] $ Only (#title blogPost1)-    V.length result `shouldBe` 0-  itDB "Get all the article titles by author name" $ do-    let q = _joinSelectWithFields @BlogPost @Author [[field| title |]] [[field| name |]]-    (query_ Select q :: (MonadIO m) => DBT m (V.Vector (Text, Text)))-      `shouldReturn` [("The Script for my requiem","Hansi Kürsch"),("Mordred's Song","Hansi Kürsch")]-  itDB "Change the name of an author" $ do-    let newAuthor = author2{name = "Hannah Kürsch"}-    update @Author newAuthor-    selectById (Only (#authorId author2))-      `shouldReturn` Just newAuthor-  itDB "Change the name of an author according to their name" $ do-    let newName = "Tiberus McElroy" :: Text-    let oldName = "Johnson McElroy" :: Text-    updateFieldsBy @Author [[field| name |]] ([field| name |], oldName) (Only newName)-     `shouldReturn` 1-  itDB "Change the author and title of a blogpost" $ do-    let newAuthorId =  UUID.toText $ getAuthorId $ #authorId author3 :: Text-    let newTitle    = "Something Entirely New" :: Text-    modifiedRows <- updateFieldsBy @BlogPost [[field| author_id |], [field| title |]] ([field| title |], #title blogPost4) (newAuthorId, newTitle)-    result <- selectManyByField @BlogPost [field| author_id |] (Only (#authorId author3))-    V.length result `shouldBe` fromIntegral modifiedRows+  liftDB $ deleteByField @BlogPost [[field| title |]] (Only @Text "Echoes from the other world")+  result1 <- liftDB $ selectManyByField @BlogPost [field| title |] $ Only (#title blogPost1)+  U.assertEqual 0 (V.length result1)++getAllTitlesByAuthorName :: TestM ()+getAllTitlesByAuthorName = do+  author <- liftDB $ instantiateRandomAuthor randomAuthorTemplate{generateName = pure "Hansi Kürsch"}++  liftDB $+    instantiateRandomBlogPost+      randomBlogPostTemplate+        { generateTitle = pure "The Script for my requiem"+        , generateAuthorId = pure (author ^. #authorId)+        }+  liftDB $+    instantiateRandomBlogPost+      randomBlogPostTemplate+        { generateAuthorId = pure (author ^. #authorId)+        , generateTitle = pure "Mordred's Song"+        }++  let q =+        _joinSelectWithFields @BlogPost @Author [[field| title |]] [[field| name |]]+          <> _where [[field| name |]]+  result <- liftDB (query Select q (Only ("Hansi Kürsch" :: Text)) :: (MonadIO m) => DBT m (Vector (Text, Text)))+  U.assertEqual [("The Script for my requiem", "Hansi Kürsch"), ("Mordred's Song", "Hansi Kürsch")] result++changeAuthorName :: TestM ()+changeAuthorName = do+  author <- liftDB $ instantiateRandomAuthor randomAuthorTemplate++  blogPost <- randomBlogPost randomBlogPostTemplate{generateAuthorId = pure (author ^. #authorId)}+  liftDB $ insertBlogPost blogPost++  let newAuthor = author{name = "Hannah Kürsch"}+  liftDB $ update @Author newAuthor+  result1 <- liftDB $ selectById (Only (#authorId author))+  U.assertEqual (Just newAuthor) result1++  author2 <- liftDB $ instantiateRandomAuthor randomAuthorTemplate+  let newAuthorId = UUID.toText $ getAuthorId $ #authorId author2 :: Text+  let newTitle = "Something Entirely New with a lone quote '" :: Text+  modifiedRows <- liftDB $ updateFieldsBy @BlogPost [[field| author_id |], [field| title |]] ([field| title |], #title blogPost) (newAuthorId, newTitle)+  result2 <- liftDB $ selectManyByField @BlogPost [field| author_id |] (Only (#authorId author2))+  U.assertEqual (fromIntegral modifiedRows) (V.length result2)++  let oldName = "Johnson McElroy" :: Text+  liftDB $ instantiateRandomAuthor randomAuthorTemplate{generateName = pure oldName}+  let newName = "Tiberus McElroy" :: Text+  result3 <- liftDB $ updateFieldsBy @Author [[field| name |]] ([field| name |], oldName) (Only newName)+  U.assertEqual 1 result3++selectWhereIn :: TestM ()+selectWhereIn = do+  author <- liftDB $ instantiateRandomAuthor randomAuthorTemplate+  blogPost <-+    liftDB $+      instantiateRandomBlogPost+        randomBlogPostTemplate+          { generateAuthorId = pure (author ^. #authorId)+          , generateTitle = pure "Testing unescaped single quotes ' :)"+          }+  result <- liftDB $ selectOneWhereIn @BlogPost [field| title |] ["Testing unescaped single quotes ' :)", "Doesn't exist lol"]+  U.assertEqual (Just blogPost) result++testSelectOrderBy :: TestM ()+testSelectOrderBy = do+  author1 <-+    liftDB $+      instantiateRandomAuthor+        randomAuthorTemplate+          { generateName = pure "Alphabetically first"+          , generateCreatedAt = pure (read "2013-03-16 21:38:36Z")+          }++  author2 <-+    liftDB $+      instantiateRandomAuthor+        randomAuthorTemplate+          { generateName = pure "Blphabetically first"+          , generateCreatedAt = pure (read "2012-03-16 21:38:36Z")+          }++  let authors = V.fromList [author1, author2]++  result1 <- V.filter (\a -> a `V.elem` authors) <$> liftDB (selectOrderBy @Author (V.fromList [([field| name |], ASC)]))+  U.assertEqual authors result1++  let reverseAuthors = V.fromList [author2, author1]+  result2 <- V.filter (\a -> a `V.elem` authors) <$> liftDB (selectOrderBy @Author (V.fromList [([field| name |], DESC)]))+  U.assertEqual reverseAuthors result2++  author3 <-+    liftDB $+      instantiateRandomAuthor+        randomAuthorTemplate+          { generateName = pure "Blphabetically first"+          , generateCreatedAt = pure (read "2011-03-16 21:38:36Z")+          }+  let threeAuthors = V.fromList [author1, author3, author2]+  result3 <-+    V.filter (\a -> a `V.elem` threeAuthors)+      <$> liftDB (selectOrderBy @Author (V.fromList [([field| name |], ASC), ([field| created_at |], ASC)]))+  U.assertEqual threeAuthors result3++selectBlogpostsByAuthorName :: TestM ()+selectBlogpostsByAuthorName = do+  author <- liftDB $ instantiateRandomAuthor randomAuthorTemplate{generateName = pure "Alfonso Bertholt"}+  blogPost1 <-+    liftDB $+      instantiateRandomBlogPost+        randomBlogPostTemplate+          { generateAuthorId = pure (author ^. #authorId)+          }+  blogPost2 <-+    liftDB $+      instantiateRandomBlogPost+        randomBlogPostTemplate+          { generateAuthorId = pure (author ^. #authorId)+          }+  result <- liftDB $ joinSelectOneByField @BlogPost @Author [field| author_id |] [field| name |] (author ^. #name)+  U.assertEqual (S.fromList [blogPost1, blogPost2]) (S.fromList $ V.toList result)++insertManyBlogPosts :: TestM ()+insertManyBlogPosts = do+  author1 <- randomAuthor randomAuthorTemplate{generateName = pure "Vivienne Brooks"}+  author2 <- randomAuthor randomAuthorTemplate{generateName = pure "Léana Garibaldi"}+  void $ liftDB $ bulkInsertAuthors [author1, author2]++  author <- liftDB $ instantiateRandomAuthor randomAuthorTemplate{generateName = pure "Léana Garibaldi"}+  blogPost1 <- randomBlogPost randomBlogPostTemplate{generateAuthorId = pure (author ^. #authorId)}+  blogPost2 <- randomBlogPost randomBlogPostTemplate{generateAuthorId = pure (author ^. #authorId)}+  void $ liftDB $ bulkInsertBlogPosts [blogPost1, blogPost2]+  result <- liftDB $ joinSelectOneByField @BlogPost @Author [field| author_id |] [field| name |] (author ^. #name)+  U.assertEqual (S.fromList [blogPost1, blogPost2]) (S.fromList $ V.toList result)++testUpsertBlogPost :: TestM ()+testUpsertBlogPost = do+  author1 <- randomAuthor randomAuthorTemplate{generateName = pure "Vivienne Brooks"}+  void $ liftDB $ insertAuthor author1+  blogPost1 <- randomBlogPost randomBlogPostTemplate{generateAuthorId = pure (author1 ^. #authorId)}+  blogPost2 <- randomBlogPost randomBlogPostTemplate{generateBlogPostId = pure (blogPost1 ^. #blogPostId), generateAuthorId = pure (author1 ^. #authorId), generateTitle = pure "New title"}++  void $ liftDB $ insertBlogPost blogPost1+  void $ liftDB $ upsertBlogPost blogPost2 [[field| title |]]++  r <- liftDB $ selectById @BlogPost (Only (blogPost1 ^. #blogPostId))+  let result = fromJust r+  U.assertEqual (result ^. #title) (blogPost2 ^. #title)

@@ -3,40 +3,147 @@  module GenericsSpec where +import Data.Aeson import Data.Text-import Database.PostgreSQL.Entity.Internal.QQ (field)+import Data.Time+import Data.UUID+import Data.Vector+import Database.PostgreSQL.Entity+import Database.PostgreSQL.Entity.Internal (getTableName)+import Database.PostgreSQL.Entity.Internal.BlogPost import Database.PostgreSQL.Entity.Internal.Unsafe (Field (Field)) import Database.PostgreSQL.Entity.Types+import Database.PostgreSQL.Simple+import Database.PostgreSQL.Simple.FromField+import Database.PostgreSQL.Simple.ToField+import Database.PostgreSQL.Transact import GHC.Generics-import Test.Hspec+import Test.Tasty+import Utils+import qualified Utils as U -data TestType-  = Test { fieldOne   :: Int-         , fieldTwo   :: Text-         , fieldThree :: [Int]-         }+data TestType = Test+  { fieldOne :: Int+  , fieldTwo :: Text+  , fieldThree :: [Int]+  }   deriving stock (Eq, Generic, Show)   deriving anyclass (Entity) -data Apple-  = AppleCons { thisField :: Text-              , thatField :: Text-              }+data Apple = AppleCons+  { thisField :: Text+  , thatField :: Text+  }   deriving stock (Eq, Generic, Show)-  deriving (Entity)+  deriving+    (Entity)     via (GenericEntity '[TableName "apples"] Apple) -spec :: Spec-spec = describe "Ensure generically-derived instances with no options are correct" $ do-  it "TestType has the expected table name" $ do-    tableName @TestType `shouldBe` "test_type"-  it "TestType has the expected field list" $ do-    fields @TestType `shouldBe` [[field| field_one |], [field| field_two |], [field| field_three |]]-  it "TestType has the expected primary key" $ do-    primaryKey @TestType `shouldBe` Field "field_one" Nothing-  it "Apple has the expected primary key" $ do-    primaryKey @Apple `shouldBe` Field "this_field" Nothing-  it "Apple has the expected table name" $ do-    tableName @Apple `shouldBe` "apples"-  it "Apple has the expected fields" $ do-    fields @Apple `shouldBe` [[field| this_field |], [field| that_field |]]+data Project = Project+  { createdAt :: ZonedTime+  , updatedAt :: ZonedTime+  , deletedAt :: Maybe ZonedTime+  , active :: Bool+  , id :: Int+  , title :: Text+  , description :: Text+  , hosts :: Vector Text+  }+  deriving (Generic, Show)+  deriving anyclass (FromRow, ToRow)+  deriving+    (Entity)+    via (GenericEntity '[Schema "projects", TableName "projects", PrimaryKey "id", FieldModifiers '[CamelToSnake]] Project)++newtype ProjectId+  = ProjectId UUID+  deriving+    (Eq, FromField, Show, ToField)+    via UUID++newtype EndpointId+  = EndpointId UUID+  deriving+    (Eq, FromField, Show, ToField)+    via UUID++data Endpoint = Endpoint+  { enpcreatedAt :: ZonedTime+  , enpupdatedAt :: ZonedTime+  , enpprojectId :: ProjectId+  , enpid :: EndpointId+  , enpurlPath :: Text+  , enpurlParams :: Value+  , enpmethod :: Text+  , enphosts :: Vector Text+  , enprequestHashes :: Vector Text+  , enpresponseHashes :: Vector Text+  , enpqueryparamHashes :: Vector Text+  }+  deriving (Generic, Show)+  deriving anyclass (FromRow, ToRow)+  deriving+    (Entity)+    via (GenericEntity '[TableName "endpoints", Schema "apis", PrimaryKey "id", FieldModifiers '[StripPrefix "enp", CamelToSnake]] Endpoint)++endpointsByProject :: ProjectId -> DBT IO (Vector Endpoint)+endpointsByProject pid = selectManyByField @Endpoint [field| project_id |] (Only pid)++endpointById :: EndpointId -> DBT IO (Maybe Endpoint)+endpointById eId = selectById @Endpoint (Only eId)++spec :: TestM TestTree+spec =+  testThese+    "Generic deriving tests"+    [ testThis "TestType has the expected table name" testExpectedTableName+    , testThis "TestType has the expected field list" testExpectedFieldList+    , testThis "TestType has the expected primary key" testExpectedPrimaryKey+    , testThis "Apple has the expected primary key" testInferredPrimaryKey+    , testThis "Apple has the expected table name" testSpecifiedTableName+    , testThis "Apple has the expected fields" testInferredFields+    , testThis "Prefix stripping works" testPrefixStrippingWorks+    , testThis "Explicit schema works" testExplicitSchemaWorks+    , testThis "Generically derived schema works" testGenericallyDerivedSchema+    , testThis "Derived primary key is not necessarily the first field" testDerivePrimaryKey+    ]++testExpectedTableName :: TestM ()+testExpectedTableName =+  U.assertEqual "test_type" (tableName @TestType)++testExpectedFieldList :: TestM ()+testExpectedFieldList =+  U.assertEqual [[field| field_one |], [field| field_two |], [field| field_three |]] (fields @TestType)++testExpectedPrimaryKey :: TestM ()+testExpectedPrimaryKey =+  U.assertEqual (Field "field_one" Nothing) (primaryKey @TestType)++testInferredPrimaryKey :: TestM ()+testInferredPrimaryKey =+  U.assertEqual (Field "this_field" Nothing) (primaryKey @Apple)++testSpecifiedTableName :: TestM ()+testSpecifiedTableName =+  U.assertEqual "apples" (tableName @Apple)++testInferredFields :: TestM ()+testInferredFields =+  U.assertEqual [[field| this_field |], [field| that_field |]] (fields @Apple)++testPrefixStrippingWorks :: TestM ()+testPrefixStrippingWorks =+  U.assertEqual (fields @Endpoint) [[field| created_at |], [field| updated_at |], [field| project_id |], [field| id |], [field| url_path |], [field| url_params |], [field| method |], [field| hosts |], [field| request_hashes |], [field| response_hashes |], [field| queryparam_hashes |]]++testExplicitSchemaWorks :: TestM ()+testExplicitSchemaWorks =+  U.assertEqual "public.\"tags\"" (getTableName @Tags)++testGenericallyDerivedSchema :: TestM ()+testGenericallyDerivedSchema =+  U.assertEqual "apis.\"endpoints\"" (getTableName @Endpoint)++testDerivePrimaryKey :: TestM ()+testDerivePrimaryKey = do+  U.assertEqual [field| id |] (primaryKey @Endpoint)

@@ -1,13 +1,38 @@ module Main where +import Data.Pool (createPool, withResource)+import qualified Database.PostgreSQL.Simple as PG+import qualified Database.Postgres.Temp as Postgres.Temp import qualified EntitySpec import qualified GenericsSpec-import Test.Hspec+import Optics.Core+import Test.Tasty (TestTree, defaultMain, testGroup)+import Utils  main :: IO ()-main = hspec spec+main = do+  env <- getTestEnvironment+  withResource (env ^. #pool) migrate+  spec <- traverse (`runTestM` env) specs+  defaultMain . testGroup "pg-entity tests" $ spec -spec :: Spec-spec = do-  GenericsSpec.spec-  EntitySpec.spec+specs :: [TestM TestTree]+specs =+  [ GenericsSpec.spec+  , EntitySpec.spec+  ]++getTestEnvironment :: IO TestEnv+getTestEnvironment = do+  eitherDb <- Postgres.Temp.start+  case eitherDb of+    Right db -> do+      pool <-+        createPool+          (PG.connectPostgreSQL $ Postgres.Temp.toConnectionString db)+          PG.close+          1+          100000000+          50+      pure TestEnv{..}+    Left _ -> error "meh"

@@ -0,0 +1,198 @@+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE TypeFamilies #-}++module Utils where++import Control.Exception.Safe+import Control.Monad.IO.Class+import Control.Monad.Reader+import Data.Kind+import Data.Pool (Pool)+import Data.Text (Text)+import Data.Time+import Data.UUID (UUID)+import qualified Data.UUID as UUID+import qualified Data.Vector as V+import Data.Word+import Database.PostgreSQL.Entity.DBT (withPool)+import Database.PostgreSQL.Simple (Connection, SqlError (..))+import Database.PostgreSQL.Transact+import GHC.Generics+import Hedgehog (MonadGen (..))+import qualified Hedgehog.Gen as H+import qualified Hedgehog.Range as Range+import Optics.Core+import Test.Tasty (TestTree)+import qualified Test.Tasty as Test+import qualified Test.Tasty.HUnit as Test++import Database.PostgreSQL.Entity.Internal.BlogPost+import Database.PostgreSQL.Simple.Migration++newtype TestM (a :: Type) = TestM {getTestM :: ReaderT TestEnv IO a}+  deriving newtype (Applicative, Functor, Monad, MonadIO, MonadThrow)++data TestEnv = TestEnv+  { pool :: Pool Connection+  }+  deriving stock (Generic)++liftDB :: DBT IO a -> TestM a+liftDB comp = do+  env <- getTestEnv+  let pool = env ^. #pool+  liftIO $+    catch+      (withPool pool comp)+      ( \(e :: SqlError) ->+          if sqlErrorMsg e == "connection disconnected"+            then withPool pool comp+            else throw e+      )++migrate :: Connection -> IO ()+migrate conn = void $ runMigrations False conn [MigrationInitialization, MigrationDirectory "./test/migrations"]++runTestM :: TestM a -> TestEnv -> IO a+runTestM comp env =+  runReaderT (getTestM comp) env++testThis :: String -> TestM () -> TestM TestTree+testThis name assertion = do+  env <- getTestEnv+  let test = runTestM assertion env+  pure $ Test.testCase name test++testThese :: String -> [TestM TestTree] -> TestM TestTree+testThese groupName tests = fmap (Test.testGroup groupName) newTests+  where+    newTests :: TestM [TestTree]+    newTests = sequenceA tests++getTestEnv :: TestM TestEnv+getTestEnv = TestM ask++assertEqual :: (Eq a, Show a) => a -> a -> TestM ()+assertEqual expected actual = liftIO $ Test.assertEqual "" expected actual++--++genAuthorId :: MonadGen m => m AuthorId+genAuthorId = AuthorId <$> genUUID++genUUID :: MonadGen m => m UUID+genUUID = UUID.fromWords <$> genWord32 <*> genWord32 <*> genWord32 <*> genWord32+  where+    genWord32 :: MonadGen m => m Word32+    genWord32 = H.word32 (Range.constant minBound maxBound)++genUUIDList :: MonadGen m => m UUIDList+genUUIDList = UUIDList . V.fromList <$> H.list (Range.linear 1 10) genUUID++genUTCTime :: MonadGen m => m UTCTime+genUTCTime = do+  year <- toInteger <$> H.int (Range.constant 2000 2022)+  month <- H.int (Range.constant 1 12)+  day <- H.int (Range.constant 1 28)+  let date = fromGregorian year month day+  secs <- toInteger <$> H.int (Range.constant 0 86401)+  pure $ UTCTime date (secondsToDiffTime secs)++genName :: MonadGen m => m Text+genName = H.text (Range.constant 3 25) H.unicode++genAuthor :: MonadGen m => m Author+genAuthor = do+  authorId <- genAuthorId+  name <- genName+  createdAt <- genUTCTime+  pure Author{..}++data RandomAuthorTemplate m = RandomAuthorTemplate+  { generateAuthorId :: m AuthorId+  , generateName :: m Text+  , generateCreatedAt :: m UTCTime+  }+  deriving stock (Generic)++randomAuthorTemplate :: MonadIO m => RandomAuthorTemplate m+randomAuthorTemplate =+  RandomAuthorTemplate+    { generateAuthorId = H.sample genAuthorId+    , generateName = H.sample genName+    , generateCreatedAt = H.sample genUTCTime+    }++randomAuthor :: MonadIO m => RandomAuthorTemplate m -> m Author+randomAuthor RandomAuthorTemplate{..} = do+  authorId <- generateAuthorId+  name <- generateName+  createdAt <- generateCreatedAt+  pure Author{..}++instantiateRandomAuthor :: (MonadIO m, m ~ IO) => RandomAuthorTemplate m -> DBT m Author+instantiateRandomAuthor RandomAuthorTemplate{..} = do+  authorId <- liftIO generateAuthorId+  name <- liftIO generateName+  createdAt <- liftIO generateCreatedAt+  let author = Author{..}+  insertAuthor author+  pure author++--++genBlogPost :: MonadGen m => m BlogPost+genBlogPost = do+  blogPostId <- genBlogPostId+  authorId <- genAuthorId+  uuidList <- genUUIDList+  title <- genName+  content <- genName+  createdAt <- genUTCTime+  pure BlogPost{..}++genBlogPostId :: MonadGen m => m BlogPostId+genBlogPostId = BlogPostId <$> genUUID++data RandomBlogPostTemplate m = RandomBlogPostTemplate+  { generateBlogPostId :: m BlogPostId+  , generateAuthorId :: m AuthorId+  , generateUUIDList :: m UUIDList+  , generateTitle :: m Text+  , generateContent :: m Text+  , generateCreatedAt :: m UTCTime+  }+  deriving stock (Generic)++randomBlogPostTemplate :: MonadIO m => RandomBlogPostTemplate m+randomBlogPostTemplate =+  RandomBlogPostTemplate+    { generateBlogPostId = H.sample genBlogPostId+    , generateAuthorId = H.sample genAuthorId+    , generateUUIDList = H.sample genUUIDList+    , generateTitle = H.sample genName+    , generateContent = H.sample genName+    , generateCreatedAt = H.sample genUTCTime+    }++randomBlogPost :: MonadIO m => RandomBlogPostTemplate m -> m BlogPost+randomBlogPost RandomBlogPostTemplate{..} = do+  blogPostId <- generateBlogPostId+  authorId <- generateAuthorId+  uuidList <- generateUUIDList+  title <- generateTitle+  content <- generateContent+  createdAt <- generateCreatedAt+  pure BlogPost{..}++instantiateRandomBlogPost :: (MonadIO m, m ~ IO) => RandomBlogPostTemplate m -> DBT m BlogPost+instantiateRandomBlogPost RandomBlogPostTemplate{..} = do+  blogPostId <- liftIO generateBlogPostId+  authorId <- liftIO generateAuthorId+  uuidList <- liftIO generateUUIDList+  title <- liftIO generateTitle+  content <- liftIO generateContent+  createdAt <- liftIO generateCreatedAt+  let blogPost = BlogPost{..}+  insertBlogPost blogPost+  pure blogPost