packages feed

pg-entity (empty) → 0.0.1.0

raw patch · 14 files changed

+1802/−0 lines, 14 filesdep +basedep +bytestringdep +colourista

Dependencies added: base, bytestring, colourista, exceptions, hspec, hspec-expectations-lifted, hspec-pg-transact, monad-control, parsec, pg-entity, pg-transact, postgresql-simple, postgresql-simple-migration, resource-pool, safe-exceptions, template-haskell, text, text-manipulate, time, uuid, vector

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for Entity++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE.md view
@@ -0,0 +1,20 @@+Copyright (c) 2021 Théophile Choutri++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,198 @@+# PG-Entity [![CI-badge][CI-badge]][CI-url] [![docs][docs]][docs-url] ![simple-haskell][simple-haskell]++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+  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+  quasi-quoters are provided to denote fields in a safer way. +* Escape hatches are provided at every level. The types that are manipulated are Query for which an `IsString` instance exists.+  Don't force yourself to use the higher-level API if the lower-level combinators work for you, and if those don't either, “Just Write SQL”™.++Its dependency footprint is optimised for my own setups, and as such it makes use of [text][text], [vector][vector] and+[pg-transact][pg-transact].++++Table of Contents+=================++* [Installation](#installation)+* [Documentation](#documentation)+  * [Usage](#usage)+  * [Escape hatches](#escape-hatches)+* [Acknowledgements](#acknowledgements)++## Installation++At present time, `pg-entity` is published on Hackage but not on Stackage. To use it in your projects, add it in your+cabal file like this:++```+pg-entity ^>= 0.0+```++or in your `stack.yaml` file:++```+extra-deps:+  - pg-entity-0.0.1.0+```++The following GHC versions are supported:++* 8.8+* 8.10+* 9.0++## Documentation++This library aims to be thoroughly tested, by the means of Oleg Grerus' [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+something is badly explained and should be improved.++You will find the Tutorial [here][docs-url], and you will find below a short showcase of the library.++### Usage++The idea is to implement the `Entity` typeclass for the datatypes that represent your PostgreSQL table. ++```Haskell+-- Traditional list & string syntax+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+-- Quasi-quoter to construct SQL expressions+{-# LANGUAGE QuasiQuotes #-}+-- Deriving machinery+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingVia #-}++import Data.UUID (UUID)+import Data.Vector (Vector)+import Database.PostgreSQL.Simple.SqlQQ++import Database.PostgreSQL.Entity++-- This is our Primary Key newtype. It is wrapped in a newtype to make+-- it impossible to mitake with a plain `UUID`, but we still want to+-- benefit from the pre-existing typeclass instances that exist for+-- `UUID`. You can read the last two lines as:+-- > We use the definitions posessed by `UUID` for our own newtype.+newtype JobId = JobId { getJobId :: UUID }+  deriving (Eq, Show, FromField, ToField)+    via UUID++-- A straightforward table definition, which lets us use+-- the DerivingVia mechanism to declare the table name+-- in the `deriving` clause, and infer the fields and primary key.+-- The field names will be converted to snake_case.++data Job+  = Job { jobId    :: JobId+        , lockedAt :: UTCTime+        , jobName  :: Text+        }+  deriving stock (Eq, Generic, Show)+  deriving anyclass (FromRow, ToRow)+  deriving Entity+    via (GenericEntity '[TableName "jobs"] Job)++-- In the above deriving clause, we only had to specify the table name in order to pluralise it,+-- leaving the guessing of the primary key and the table names to the library.++-- Below is a richer table definition that needs some type annotations to help PostgreSQL.+-- We will have to write out the full instance by hand++newtype BagId = BagId { getBagId :: UUID }+  deriving (Eq, Show, FromField, ToField)+    via UUID++-- | This is a PostgreSQL Enum, which needs to be marked as such in SQL type annotations.+data Properties = P1 | P2 | P3+  deriving stock (Eq, Generic, Show)+  deriving anyclass (FromRow, ToRow)++data Bag+  = Bag { bagId      :: BagId+        , someField  :: Vector UUID+        , properties :: Vector Properties+        }+  deriving stock (Eq, Generic, Show)+  deriving anyclass (FromRow, ToRow)+++instance Entity Bag where+  tableName  = "bags"+  primaryKey = [field| bag_id |]+  fields     = [ [field| bag_id |]+               , [field| some_field :: uuid[] |]+               , [field| properties :: properties[] |]+               ]++-- You can write specialised functions to remove the noise of Type Applications++insertBag :: Bag -> DBT IO ()+insertBag = insert -- `insert` will be specialised to `Bag`++-- And you can insert raw SQL through postgresql-simple++isJobLocked :: Int -> DBT IO (Only Bool)+isJobLocked jobId = queryOne Select q (Only jobId)+  where q = [sql| SELECT+                    CASE WHEN locked_at IS NULL then false+                         ELSE true+                     END+                   FROM jobs WHERE job_id = ?+            |]+```++For more examples, see the [BlogPost][BlogPost-module] module for the data-type that is used throughout the tests and doctests.++### Escape hatches++Safe SQL generation is a complex subject, and it is far from being the objective of this library. The main topic it+addresses is listing the fields of a table, which is definitely something easier. This is why every level of this wrapper+is fully exposed, so that you can drop down a level at your convience.++It is my personal belief, firmly rooted in experience, that we should not aim to produce statically-checked SQL and have+it "verified" by the compiler. The techniques that would allow that in Haskell are still far from being optimised and+ergonomic. As such, this library makes no effort to produce semantically valid SQL queries, because one would have to+encode the semantics of SQL in the type system (or in a rule engine of some sort), and this is clearly not the kind of+things I want to spend my youth on.++Each function is tested for its output with doctests, and the ones that cannot (due to database connections) are tested+in the more traditional test-suite.++The conclusion is : Test your DB queries. Test the encoding/decoding. Make roundtrip tests for your data-structures.++## Acknowledgements ++I wish to thank++* Clément Delafargue, whose [anorm-pg-entity][anorm-pg-entity] library and its [initial port in Haskell][entity-blogpost-fretlink]+  are the spiritual parents of this library+* Koz Ross, for his piercing eyes and his immense patience+* Joe Kachmar, who enlightened me many times++[docs]: https://img.shields.io/badge/Tutorial%20and%20Guides-pg--entity-blueviolet+[docs-url]: https://tchoutri.github.io/pg-entity/+[docspec]: https://github.com/phadej/cabal-extras/blob/master/cabal-docspec/MANUAL.md+[pg-transact-hspec]: https://github.com/jfischoff/pg-transact-hspec.git+[entity-blogpost-fretlink]: https://tech.fretlink.com/yet-another-unsafe-db-layer/+[anorm-pg-entity]: https://github.com/CleverCloud/anorm-pg-entity+[pg-simple]: https://hackage.haskell.org/package/postgresql-simple+[pg-transact]: https://hackage.haskell.org/package/pg-transact+[text]: https://hackage.haskell.org/package/text+[vector]: https://hackage.haskell.org/package/vector+[CI-badge]: https://img.shields.io/github/workflow/status/tchoutri/pg-entity/CI?style=flat-square+[CI-url]: https://github.com/tchoutri/pg-entity/actions+[simple-haskell]: https://img.shields.io/badge/Simple-Haskell-purple?style=flat-square+[BlogPost-module]: https://github.com/tchoutri/pg-entity/blob/main/src/Database/PostgreSQL/Entity/Internal/BlogPost.hs+
+ pg-entity.cabal view
@@ -0,0 +1,126 @@+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+extra-source-files:+    CHANGELOG.md+    LICENSE.md+    README.md++source-repository head+  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++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++common common-rts-options+  ghc-options: -rtsopts+               -threaded+               -with-rtsopts=-N++library+  import: common-extensions+  import: common-ghc-options+  exposed-modules:+    Database.PostgreSQL.Entity+    Database.PostgreSQL.Entity.DBT+    Database.PostgreSQL.Entity.Internal+    Database.PostgreSQL.Entity.Internal.BlogPost+    Database.PostgreSQL.Entity.Internal.QQ+    Database.PostgreSQL.Entity.Internal.Unsafe+    Database.PostgreSQL.Entity.Types+  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++test-suite entity-test+  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+  build-depends:+    , base+    , hspec+    , hspec-expectations-lifted+    , hspec-pg-transact == 0.1.0.3+    , pg-entity+    , pg-transact+    , postgresql-simple+    , postgresql-simple-migration ^>= 0.1+    , text+    , time+    , uuid+    , vector
+ src/Database/PostgreSQL/Entity.hs view
@@ -0,0 +1,430 @@+{-# 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+  (+    -- * The /Entity/ Typeclass+    Entity (..)++    -- * Associated Types+  , Field++    -- * High-level API+    -- $highlevel+    -- ** Selection+  , selectById+  , selectOneByField+  , selectManyByField+  , selectWhereNotNull+  , selectWhereNull+  , joinSelectById+    -- ** Insertion+  , insert+    -- ** Update+  , update+  , updateFieldsBy+    -- ** Deletion+  , delete+  , deleteByField++    -- * SQL Combinators API+    -- ** Selection+  , _select+  , _selectWithFields+  , _where+  , _selectWhere+  , _selectWhereNotNull+  , _selectWhereNull+  , _joinSelect+  , _innerJoin+  , _joinSelectWithFields+    -- ** Insertion+  , _insert+    -- ** Update+  , _update+  , _updateBy+  , _updateFields+  , _updateFieldsBy+    -- ** Deletion+  , _delete+  , _deleteWhere+  ) where++import Control.Monad (void)+import Control.Monad.IO.Class (MonadIO)+import Data.Foldable (fold)+import Data.Int+import Data.Vector (Vector)+import qualified Data.Vector as V+import Database.PostgreSQL.Simple (Only (..))+import Database.PostgreSQL.Simple.FromRow (FromRow)+import Database.PostgreSQL.Simple.ToField (ToField)+import Database.PostgreSQL.Simple.ToRow (ToRow (..))+import Database.PostgreSQL.Simple.Types (Query (..))+import Database.PostgreSQL.Transact (DBT)++import Database.PostgreSQL.Entity.DBT (QueryNature (..), execute, query, queryOne, query_)+import Database.PostgreSQL.Entity.Internal+import Database.PostgreSQL.Entity.Types++-- $setup+-- >>> :set -XQuasiQuotes+-- >>> :set -XOverloadedStrings+-- >>> :set -XOverloadedLists+-- >>> :set -XTypeApplications+-- >>> import Database.PostgreSQL.Entity+-- >>> import Database.PostgreSQL.Entity.Internal.BlogPost+-- >>> import Database.PostgreSQL.Entity.Internal.QQ++-- $highlevel+-- Glossary / Tips’n’Tricks+--+-- * @e@, @e1@, @e2@: Represents an @Entity@+-- * @value@: Represents a Haskell value that can be serialised to PostgreSQL+-- * @Field@: Parameters of type @Field@ can most often be passed in their textual form inside the 'field' quasi-quoter,+--   like @[field| author_id :: uuid|]@. This metaprogramming technique is here to better prevent empty fields from being passed.+--   The PostgreSQL type annotation is optional, but necessary for arrays of UUIDs and of custom enums.+--+-- Consult the [test suite](https://github.com/tchoutri/pg-entity/tree/main/test) to see those functions in action.++-- | 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 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 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 f value = query Select (_selectWhere @e [f]) value++-- | Select statement with a non-null condition+--+-- 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 fs = query_ Select (_selectWhereNotNull @e fs)++-- | Select statement with a null condition+--+-- 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 fs = query_ Select (_selectWhereNull @e fs)++-- | 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 = query_ Select (_joinSelect @e1 @e2)++-- | Insert an entity.+--+-- @since 0.0.1.0+insert :: forall e values m.+       (Entity e, ToRow values, MonadIO m)+       => values -> DBT m ()+insert fs = void $ execute Insert (_insert @e) fs++-- | Update an entity.+--+-- The Id of the entity is put at the end of the query automatically through the use of 'UpdateRow'.+-- __Examples__+--+-- > let newAuthor = oldAuthor{…}+-- > update @Author newAuthor+--+-- @since 0.0.1.0+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+--+-- == Example+--+-- > let newName = "Tiberus McElroy" :: Text+-- > let oldName = "Johnson McElroy" :: Text+-- > 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 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 value = deleteByField @e [primaryKey @e] value++-- | Delete rows according to the given fields+--+-- == Example+--+-- > 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 fs values = void $ execute Delete (_deleteWhere @e fs) values++-- * SQL combinators API++-- | Produce a SELECT statement for a given entity.+--+-- __Examples__+--+-- >>> _select @BlogPost+-- "SELECT blogposts.\"blogpost_id\", blogposts.\"author_id\", blogposts.\"uuid_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\" FROM \"blogposts\""+--+-- @since 0.0.1.0+_select :: forall e. Entity e => Query+_select = textToQuery $ "SELECT " <> expandQualifiedFields @e <> " FROM " <> getTableName @e++-- | Produce a SELECT statement with explicit fields for a given entity+--+-- __Examples__+--+-- >>> _selectWithFields @BlogPost [ [field| blogpost_id |], [field| created_at |] ]+-- "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++-- | 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.+--+-- __Examples__+--+-- >>> _select @BlogPost <> _where @BlogPost [[field| blogpost_id |]]+-- "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[]"+--+-- @since 0.0.1.0+_where :: forall e. Entity e => 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)++-- | Produce a SELECT statement for a given entity and fields.+--+-- __Examples__+--+-- >>> _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\" = ?"+--+-- @since 0.0.1.0+_selectWhere :: forall e. Entity e => Vector Field -> Query+_selectWhere fs = _select @e <> _where @e fs++-- | Produce a SELECT statement where the provided fields are checked for being non-null.+-- r+--+-- >>> _selectWhereNotNull @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\" IS NOT NULL"+--+-- @since 0.0.1.0+_selectWhereNotNull :: forall e. Entity e => Vector Field -> Query+_selectWhereNotNull fs = _select @e <> textToQuery (" WHERE " <> isNotNull fs)++-- | Produce a SELECT statement where the provided fields are checked for being null.+--+-- >>> _selectWhereNull @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\" IS NULL"+--+-- @since 0.0.1.0+_selectWhereNull :: forall e. Entity e => Vector Field -> Query+_selectWhereNull fs = _select @e <> textToQuery (" WHERE " <> isNull fs)++-- | Produce a "SELECT FROM" over two entities.+--+-- __Examples__+--+-- >>> _joinSelect @BlogPost @Author+-- "SELECT blogposts.\"blogpost_id\", blogposts.\"author_id\", blogposts.\"uuid_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\", authors.\"author_id\", authors.\"name\", authors.\"created_at\" FROM \"blogposts\" INNER JOIN \"authors\" USING(author_id)"+--+-- @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))++-- | Produce a "INNER JOIN … USING(…)" fragment.+--+-- __Examples__+--+-- >>> _innerJoin @BlogPost [field| author_id |]+-- " INNER JOIN \"blogposts\" USING(author_id)"+--+-- @since 0.0.1.0+_innerJoin :: forall e. (Entity e) => Field -> Query+_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.+--+-- __Examples__+--+-- >>> _joinSelectWithFields @BlogPost @Author [ [field| title |] ] [ [field| name |] ]+-- "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 fs1 fs2 =+  textToQuery $ "SELECT " <> expandQualifiedFields' fs1 tn1+    <> ", " <> expandQualifiedFields' fs2 tn2+    <> " FROM " <> getTableName @e1+    <> queryToText (_innerJoin @e2 (primaryKey @e2))+  where+    tn1 = tableName @e1+    tn2 = tableName @e2++-- | 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[], ?, ?, ?)"+--+-- @since 0.0.1.0+_insert :: forall e. Entity e => Query+_insert = textToQuery $ "INSERT INTO " <> getTableName @e <> " " <> fs <> " VALUES " <> ps+  where+    fs = inParens (expandFields @e)+    ps = inParens (generatePlaceholders $ fields @e)++-- | Produce an UPDATE statement for the given entity by primary key+--+-- __Examples__+--+-- >>> _update @Author+-- "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\" = ?"+--+-- @since 0.0.1.0++_update :: forall e. Entity e => Query+_update = _updateBy @e (primaryKey @e)++-- | Produce an UPDATE statement for the given entity by the given field.+--+-- __Examples__+--+-- >>> _updateBy @Author [field| name |]+-- "UPDATE \"authors\" SET (\"name\", \"created_at\") = ROW(?, ?) WHERE \"name\" = ?"+--+-- @since 0.0.1.0+_updateBy :: forall e. Entity e => Field -> Query+_updateBy f = _updateFieldsBy @e (fields @e) f++-- | Produce an UPDATE statement for the given entity and fields, by primary key.+--+-- >>> _updateFields @Author [ [field| name |] ]+-- "UPDATE \"authors\" SET (\"name\") = ROW(?) WHERE \"author_id\" = ?"+--+-- @since 0.0.1.0+_updateFields :: forall e. Entity e => Vector Field -> Query+_updateFields fs = _updateFieldsBy @e fs (primaryKey @e)++-- | Produce an UPDATE statement for the given entity and fields, by the specified field.+--+-- >>> _updateFieldsBy @Author [ [field| name |] ] [field| name |]+-- "UPDATE \"authors\" SET (\"name\") = ROW(?) WHERE \"name\" = ?"+--+-- >>> _updateFieldsBy @BlogPost [[field| author_id |], [field| title |]] [field| title |]+-- "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]+  where+    fs = V.filter (/= (primaryKey @e)) fs'+    newValues = "ROW" <> inParens (generatePlaceholders 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+--+-- __Examples__+--+-- >>> _delete @BlogPost+-- "DELETE FROM \"blogposts\" WHERE \"blogpost_id\" = ?"+--+-- @since 0.0.1.0+_delete :: forall e. Entity e => Query+_delete = textToQuery ("DELETE FROM " <> getTableName @e) <> _where @e [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\" = ?"+--+-- @since 0.0.1.0+_deleteWhere :: forall e. Entity e => Vector Field -> Query+_deleteWhere fs = textToQuery ("DELETE FROM " <> (tableName @e)) <> _where @e fs
+ src/Database/PostgreSQL/Entity/DBT.hs view
@@ -0,0 +1,132 @@+{-|+  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+  , query+  , query_+  , queryOne+  , QueryNature(..)+  ) where++import Colourista.IO (cyanMessage, redMessage, yellowMessage)+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 subPools timeout connections =+  createPool (connect connectInfo) close subPools timeout connections++-- | Run a DBT action with no explicit error handling.+--+-- This functions is suited for using 'MonadError' error handling.+--+-- === __Example__+--+-- > let e1 = E 1 True True+-- > result <- runExceptT @EntityError $ do+-- >   withPool pool $ insertEntity e1+-- >   withPool pool $ markForProcessing 1+-- > case result of+-- >   Left err -> print err+-- >   Right _  -> putStrLn "Everything went well"+--+-- 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++-- | 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 queryNature q params = do+  logQueryFormat queryNature q params+  V.fromList <$> PGT.query q params++-- | 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 queryNature q params = do+  logQueryFormat queryNature q params+  result <- PGT.query q params+  pure $ listToMaybe result++-- | 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 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 queryNature q params = do+  logQueryFormat queryNature q params+  PGT.execute q params++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++-- | This sum type is given to the 'query', 'queryOne' and 'execute' functions to help+-- with logging.+--+-- @since 0.0.1.0+data QueryNature = Select | Insert | Update | Delete deriving (Eq, Show)
+ src/Database/PostgreSQL/Entity/Internal.hs view
@@ -0,0 +1,234 @@+{-# 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+  ( -- * Helpers+    isNotNull+  , isNull+  , inParens+  , quoteName+  , getTableName+  , expandFields+  , expandQualifiedFields+  , expandQualifiedFields'+  , qualifyFields+  , placeholder+  , generatePlaceholders+  , textToQuery+  , queryToText+  , intercalateVector+  ) where++import Data.String (fromString)+import Data.Text (Text, unpack)+import Data.Text.Encoding (decodeUtf8)+import Data.Vector (Vector)+import qualified Data.Vector as V+import Database.PostgreSQL.Simple.Types (Query (..))++import Data.Foldable (fold)+import Database.PostgreSQL.Entity.Internal.Unsafe (Field (Field))+import Database.PostgreSQL.Entity.Types++-- $setup+-- >>> :set -XQuasiQuotes+-- >>> :set -XOverloadedLists+-- >>> :set -XTypeApplications+-- >>> import Database.PostgreSQL.Entity+-- >>> import Database.PostgreSQL.Entity.Internal.BlogPost+-- >>> import Database.PostgreSQL.Entity.Internal.QQ+-- >>> import Database.PostgreSQL.Entity.Internal.Unsafe++-- | Wrap the given text between parentheses+--+-- __Examples__+--+-- >>> inParens "wrap me!"+-- "(wrap me!)"+--+-- @since 0.0.1.0+inParens :: Text -> Text+inParens t = "(" <> t <> ")"++-- | Wrap the given text between double quotes+--+-- __Examples__+--+-- >>> quoteName "meow."+-- "\"meow.\""+--+-- @since 0.0.1.0+quoteName :: Text -> Text+quoteName n = "\"" <> n <> "\""++-- | Safe getter that quotes a table name+--+-- __Examples__+--+-- >>> getTableName @Author+-- "\"authors\""+getTableName :: forall e. Entity e => Text+getTableName = quoteName (tableName @e)++getFieldName :: Field -> Text+getFieldName = quoteName . fieldName++-- | Produce a comma-separated list of an entity's fields.+--+-- __Examples__+--+-- >>> expandFields @BlogPost+-- "\"blogpost_id\", \"author_id\", \"uuid_list\", \"title\", \"content\", \"created_at\""+--+-- @since 0.0.1.0+expandFields :: forall e. Entity e => Text+expandFields = V.foldl1' (\element acc -> element <> ", " <> acc) (getFieldName <$> fields @e)++-- | Produce a comma-separated list of an entity's fields, qualified with the table name+--+-- __Examples__+--+-- >>> expandQualifiedFields @BlogPost+-- "blogposts.\"blogpost_id\", blogposts.\"author_id\", blogposts.\"uuid_list\", blogposts.\"title\", blogposts.\"content\", blogposts.\"created_at\""+--+-- @since 0.0.1.0+expandQualifiedFields :: forall e. Entity e => Text+expandQualifiedFields = expandQualifiedFields' (fields @e) prefix+  where+    prefix = tableName @e++-- | Produce a comma-separated list of an entity's 'fields', qualified with an arbitrary prefix+--+-- __Examples__+--+-- >>> expandQualifiedFields' (fields @BlogPost) "legacy"+-- "legacy.\"blogpost_id\", legacy.\"author_id\", legacy.\"uuid_list\", legacy.\"title\", legacy.\"content\", legacy.\"created_at\""+--+-- @since 0.0.1.0+expandQualifiedFields' :: Vector Field -> Text -> Text+expandQualifiedFields' fs prefix = V.foldl1' (\element acc -> element <> ", " <> acc) fs'+  where+    fs' = fieldName <$> qualifyFields prefix fs++-- | 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]+--+-- @since 0.0.1.0+qualifyFields :: Text -> Vector Field -> Vector Field+qualifyFields p fs = fmap (\(Field f t) -> Field (p <> "." <> quoteName f) t) fs++-- | Produce a placeholder of the form @\"field\" = ?@ with an optional type annotation.+--+-- __Examples__+--+-- >>> placeholder [field| id |]+-- "\"id\" = ?"+--+-- >>> placeholder $ [field| ids :: uuid[] |]+-- "\"ids\" = ?::uuid[]"+--+-- >>> fmap placeholder $ fields @BlogPost+-- ["\"blogpost_id\" = ?","\"author_id\" = ?","\"uuid_list\" = ?::uuid[]","\"title\" = ?","\"content\" = ?","\"created_at\" = ?"]+--+-- @since 0.0.1.0+placeholder :: Field -> Text+placeholder (Field f Nothing)  = quoteName f <> " = ?"+placeholder (Field f (Just t)) = quoteName f <> " = ?::" <> t++-- | Generate an appropriate number of “?” placeholders given a vector of fields.+--+-- Used to generate INSERT queries.+--+-- __Examples__+--+-- >>> generatePlaceholders $ fields @BlogPost+-- "?, ?, ?::uuid[], ?, ?, ?"+--+-- @since 0.0.1.0+generatePlaceholders :: Vector Field -> Text+generatePlaceholders vf = fold $ intercalateVector ", " $ fmap ph vf+  where+    ph (Field _ t) = maybe "?" (\t' -> "?::" <> t') t++-- | Produce an IS NOT NULL statement given a vector of fields+--+-- >>> isNotNull [ [field| possibly_empty |] ]+-- "\"possibly_empty\" IS NOT NULL"+--+-- >>> isNotNull [[field| possibly_empty |], [field| that_one_too |]]+-- "\"possibly_empty\" IS NOT NULL AND \"that_one_too\" IS NOT NULL"+--+-- @since 0.0.1.0+isNotNull :: Vector Field -> Text+isNotNull fs' = fold $ intercalateVector " AND " (fmap process fieldNames)+  where+    fieldNames = fmap fieldName fs'+    process f = quoteName f <> " IS NOT NULL"++-- | Produce an IS NULL statement given a vector of fields+--+-- >>> isNull [ [field| possibly_empty |] ]+-- "\"possibly_empty\" IS NULL"+--+-- >>> isNull [[field| possibly_empty |], [field| that_one_too |]]+-- "\"possibly_empty\" IS NULL AND \"that_one_too\" IS NULL"+--+-- @since 0.0.1.0+isNull :: Vector Field -> Text+isNull fs' = fold $ intercalateVector " AND " (fmap process fieldNames)+  where+    fieldNames = fmap fieldName fs'+    process f = quoteName f <> " IS NULL"++-- | Since the 'Query' type has an 'IsString' instance, the process of converting from 'Text' to 'String' to 'Query' is+-- factored into this function+--+-- ⚠ This may be dangerous and an unregulated usage of this function may expose to you SQL injection attacks+-- @since 0.0.1.0+textToQuery :: Text -> Query+textToQuery = fromString . unpack++-- | For cases where combinator composition is tricky, we can safely get back to a 'Text' string from a 'Query'+--+-- ⚠ This may be dangerous and an unregulated usage of this function may expose to you SQL injection attacks+-- @since 0.0.1.0+queryToText :: Query -> Text+queryToText = decodeUtf8 . fromQuery++-- | The 'intercalateVector' function takes a Text and a Vector Text and concatenates the vector after interspersing+-- the first argument between each element of the list.+--+-- __Examples__+--+-- >>> intercalateVector "~" []+-- []+--+-- >>> intercalateVector "~" ["nyan"]+-- ["nyan"]+--+-- >>> intercalateVector "~" ["nyan", "nyan", "nyan"]+-- ["nyan","~","nyan","~","nyan"]+--+-- @since 0.0.1.0+intercalateVector :: Text -> Vector Text -> Vector Text+intercalateVector sep vt | V.null vt = vt+                         | otherwise = V.cons x (go xs)+  where+    (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)))
+ src/Database/PostgreSQL/Entity/Internal/BlogPost.hs view
@@ -0,0 +1,101 @@+{-# 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 where++import Data.Text (Text)+import Data.Time (UTCTime)+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.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 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)+    via UUID++-- | Author data-type+data Author+  = Author { authorId  :: AuthorId+           , name      :: Text+           , createdAt :: UTCTime+           }+  deriving stock (Eq, Generic, Show)+  deriving anyclass (FromRow, ToRow)+  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)+    via 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)+  deriving anyclass (FromRow, ToRow)++instance HasField x BlogPost a => IsLabel x (BlogPost -> a) where+  fromLabel = getField @x++instance Entity BlogPost where+  tableName  = "blogposts"+  primaryKey = [field| blogpost_id |]+  fields = [ [field| blogpost_id |]+           , [field| author_id |]+           , [field| uuid_list :: uuid[] |]+           , [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++-- | A specialisation of the 'Database.PostgreSQL.Entity.insert function.+-- @insertAuthor = insert \@Author@+insertAuthor :: Author -> DBT IO ()+insertAuthor = insert @Author
+ src/Database/PostgreSQL/Entity/Internal/QQ.hs view
@@ -0,0 +1,85 @@+{-# 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 (field) where++import Data.Text (Text, pack)+import Database.PostgreSQL.Entity.Internal.Unsafe (Field (Field))+import Language.Haskell.TH (Dec, Exp, Pat, Q, Type)+import Language.Haskell.TH.Quote (QuasiQuoter (QuasiQuoter))+import Language.Haskell.TH.Syntax (lift)+import Text.Parsec (Parsec, anyChar, manyTill, parse, space, spaces, string, try, (<|>))++-- | A quasi-quoter for safely constructing 'Field's.+--+-- == Example:+--+-- > instance Entity BlogPost where+-- >   tableName  = "blogposts"+-- >   primaryKey = [field| blogpost_id |]+-- >   fields = [ [field| blogpost_id |]+-- >            , [field| author_id |]+-- >            , [field| uuid_list :: uuid[] |] -- ← This is where we specify an optional PostgreSQL type annotation+-- >            , [field| title |]+-- >            , [field| content |]+-- >            , [field| created_at |]+-- >            ]+--+-- @since 0.1.0.0+field :: QuasiQuoter+field = QuasiQuoter fieldExp errorFieldPat errorFieldType errorFieldDec++-- Helpers++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)) |]++errorFieldPat :: String -> Q Pat+errorFieldPat _ = fail "Cannot use 'field' in a pattern context."++fieldParser :: Parsec String () (Text, Maybe Text)+fieldParser = do+  spaces+  res <- try withType <|> noType+  spaces+  pure res+  where+    withType :: Parsec String () (Text, Maybe Text)+    withType = do+      name <- manyTill anyChar (try space)+      case name of+        [] -> fail "Cannot have an empty field name."+        _ -> do+          spaces+          _ <- string "::"+          spaces+          typ <- manyTill anyChar (try space)+          case typ of+            [] -> fail "Cannot have an empty type."+            _  -> 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)++errorFieldType :: String -> Q Type+errorFieldType _ = fail "Cannot use 'field' in a type context."++errorFieldDec :: String -> Q [Dec]+errorFieldDec _ = fail "Cannot use 'field' in a declaration context."
+ src/Database/PostgreSQL/Entity/Internal/Unsafe.hs view
@@ -0,0 +1,51 @@+{-# 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+  (+    Field (..)+  ) where++import Data.Kind+import Data.String+import Data.Text (Text)+import GHC.TypeLits++-- | A wrapper for table fields.+--+-- @since 0.0.1.0+data Field+  = Field Text (Maybe Text)+  deriving stock (Eq, Show)++{-| 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."+    )
+ src/Database/PostgreSQL/Entity/Types.hs view
@@ -0,0 +1,221 @@+{-|+  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+  (+    -- * The /Entity/ Typeclass+    Entity (..)++    -- * Associated Types+  , Field+  , field+  , fieldName+  , fieldType+  , UpdateRow(..)++    -- * Generics+  , Options(..)+  , defaultEntityOptions++    -- * DerivingVia Options+  , GenericEntity(..)+  , EntityOptions(..)+  , PrimaryKey+  , TableName+  ) where++import Data.Kind+import Data.Proxy+import Data.Text (Text, pack)+import qualified Data.Text.Manipulate as T+import Data.Vector (Vector)+import qualified Data.Vector as V+import Database.PostgreSQL.Entity.Internal.QQ (field)+import Database.PostgreSQL.Entity.Internal.Unsafe (Field (Field))+import Database.PostgreSQL.Simple.ToRow (ToRow (..))+import GHC.Generics+import GHC.TypeLits++-- | An 'Entity' stores the following information about the structure of a database table:+--+-- * Its name+-- * Its primary key+-- * The fields it contains+--+-- == Example+--+-- > data ExampleEntity = E+-- >   { key    :: Key+-- >   , field1 :: Int+-- >   , field2 :: Bool+-- >   }+-- >   deriving stock (Eq, Show, Generic)+-- >   deriving anyclass (FromRow, ToRow)+-- >   deriving Entity+-- >      via (GenericEntity '[TableName "entities"] ExampleEntity)+--+-- When using the functions provided by this library, you will sometimes need to be explicit about the Entity you are+-- referring to.+--+-- @since 0.0.1.0+class Entity e where+  -- | The name of the table in the PostgreSQL database.+  tableName :: Text+  default tableName :: (GetTableName (Rep e)) => Text+  tableName = getTableName @(Rep e) defaultEntityOptions+  -- | 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+  -- | The fields of the table.+  fields :: Vector Field+  default fields :: (GetFields (Rep e)) => Vector Field+  fields = getField @(Rep e) defaultEntityOptions++-- The sub-class that fetches the table name+class GetTableName (e :: Type -> Type) where+  getTableName :: Options -> Text++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+  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+  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+  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+  getTableName _opts = error "You don't have to derive GetTableName for a product type"++instance GetTableName e => GetTableName (M1 C _1 e) where+  getTableName opts = getTableName @e opts++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)++-- 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+  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+  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+  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+  getField _opts = error "You can't derive Entity for a type constructor's field"++instance (GetFields e, GetFields f) => GetFields (e :*: f) where+  getField opts = getField @e opts <> getField @f opts++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+  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)++-- Deriving Via machinery++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)++  fields = getField @(Rep e) (entityOptions @t)++-- | Term-level options+data Options+  = Options { tableNameModifier  :: Text -> Text+            , primaryKeyModifier :: Text -> Text+            , fieldModifier      :: Text -> Text+            }++defaultEntityOptions :: Options+defaultEntityOptions = Options T.toSnake T.toSnake T.toSnake++-- | Type-level options for Deriving Via+class EntityOptions xs where+  entityOptions :: Options++instance EntityOptions '[] where+  entityOptions = defaultEntityOptions++instance (GetName name, EntityOptions xs) => EntityOptions (TableName name ': xs) where+  entityOptions = (entityOptions @xs){tableNameModifier = const (getName @name)}++instance (GetName name, EntityOptions xs) => EntityOptions (PrimaryKey name ': xs) where+  entityOptions = (entityOptions @xs){primaryKeyModifier = const (getName @name)}++data TableName t++data PrimaryKey t++class GetName name where+  getName :: Text++instance (KnownSymbol name, NonEmptyText name) => GetName name where+  getName = pack (symbolVal (Proxy @name))++type family NonEmptyText (xs :: Symbol) :: Constraint where+  NonEmptyText "" = TypeError ('Text "User-provided string cannot be empty!")+  NonEmptyText _  = ()++-- | Get the name of a field.+--+-- @since 0.1.0.0+fieldName :: Field -> Text+fieldName (Field name _) = name++-- | Get the type of a field, if any.+--+-- @since 0.1.0.0+fieldType :: Field -> Maybe Text+fieldType (Field _ typ) = typ++-- | Wrapper used by the update function in order to have the primary key as the last parameter passed,+-- since it appears in the WHERE clause.+--+-- @since 0.0.1.0+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+
+ test/EntitySpec.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE QuasiQuotes #-}++module EntitySpec where++import Control.Monad (void)+import Control.Monad.IO.Class+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.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)++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{..}++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{..}++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{..}++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{..}++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{..}++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{..}++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{..}+++migrate :: Connection -> IO ()+migrate conn = void $ runMigrations False conn [MigrationInitialization, MigrationDirectory "./test/migrations"]++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
+ test/GenericsSpec.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE QuasiQuotes #-}++module GenericsSpec where++import Data.Text+import Database.PostgreSQL.Entity.Internal.QQ (field)+import Database.PostgreSQL.Entity.Internal.Unsafe (Field (Field))+import Database.PostgreSQL.Entity.Types+import GHC.Generics+import Test.Hspec++data TestType+  = Test { fieldOne   :: Int+         , fieldTwo   :: Text+         , fieldThree :: [Int]+         }+  deriving stock (Eq, Generic, Show)+  deriving anyclass (Entity)++data Apple+  = AppleCons { thisField :: Text+              , thatField :: Text+              }+  deriving stock (Eq, Generic, Show)+  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 |]]
+ test/Main.hs view
@@ -0,0 +1,13 @@+module Main where++import qualified EntitySpec+import qualified GenericsSpec+import Test.Hspec++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+  GenericsSpec.spec+  EntitySpec.spec