Entity.hs

{-# 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