CheckedEntities.hs

{-# LANGUAGE UndecidableInstances #-}

-- | Checked database types
module Database.Beam.Migrate.Types.CheckedEntities where

import Database.Beam
import Database.Beam.Backend.SQL
import Database.Beam.Schema.Tables

import Database.Beam.Migrate.Checks
import Database.Beam.Migrate.SQL.SQL92
import Database.Beam.Migrate.SQL.Types (BeamSqlBackendIndexSyntax)
import Database.Beam.Migrate.Generics.Tables
import Database.Beam.Migrate.Types.Predicates

import Control.Applicative
import Control.Monad.Writer
import Control.Monad.Identity

import Data.Kind (Constraint, Type)
import qualified Data.List.NonEmpty as NE (NonEmpty, nonEmpty)
import Data.Maybe
import Data.Monoid
import Data.Proxy
import Data.Text (Text)
import Data.String

import GHC.Generics

import Lens.Micro (Lens', (&), (^.), (.~), (%~))

-- * Checked Database Entities

-- | Like 'IsDatabaseEntity' in @beam-core@, but for entities against which we
-- can generate 'DatabasePredicate's. Conceptually, this is the same as
-- 'IsDatabaseEntity', but with one extra function to generate
-- 'DatabasePredicate's from the description.
class IsDatabaseEntity be entity => IsCheckedDatabaseEntity be entity where
  -- | The type of the descriptor for this checked entity. Usually this wraps
  -- the corresponding 'DatabaseEntityDescriptor' from 'IsDatabaseEntity', along
  -- with some mechanism for generating 'DatabasePredicate's.
  data CheckedDatabaseEntityDescriptor be entity :: Type

  -- | Like 'DatabaseEntityDefaultRequirements' but for checked entities
  type CheckedDatabaseEntityDefaultRequirements be entity :: Constraint

  -- | Produce the corresponding 'DatabaseEntityDescriptor'
  unCheck :: CheckedDatabaseEntityDescriptor be entity -> DatabaseEntityDescriptor be entity
  unCheck d = d ^. unChecked

  -- | A lens to access the internal unchecked descriptor
  unChecked :: Lens' (CheckedDatabaseEntityDescriptor be entity) (DatabaseEntityDescriptor be entity)

  -- | Produce the set of 'DatabasePredicate's that apply to this entity
  collectEntityChecks :: CheckedDatabaseEntityDescriptor be entity -> [ SomeDatabasePredicate ]

  -- | Like 'dbEntityAuto' but for checked databases. Most often, this wraps
  -- 'dbEntityAuto' and provides some means to generate 'DatabasePredicate's
  checkedDbEntityAuto :: CheckedDatabaseEntityDefaultRequirements be entity
                      => Text -> CheckedDatabaseEntityDescriptor be entity

-- | Like 'DatabaseEntity' but for checked databases
data CheckedDatabaseEntity be (db :: (Type -> Type) -> Type) entityType where
  CheckedDatabaseEntity :: IsCheckedDatabaseEntity be entityType
                        => CheckedDatabaseEntityDescriptor be entityType
                        -> [ SomeDatabasePredicate ]
                        -> CheckedDatabaseEntity be db entityType

checkedDbDescriptor :: Lens' (CheckedDatabaseEntity be db entityType)
                             (CheckedDatabaseEntityDescriptor be entityType)
checkedDbDescriptor fn (CheckedDatabaseEntity f ps) =
    (\f' -> CheckedDatabaseEntity f' ps) <$> fn f

-- | The type of a checked database descriptor. Conceptually, this is just a
-- 'DatabaseSettings' with a set of predicates. Use 'unCheckDatabase' to get the
-- regular 'DatabaseSettings' object and 'collectChecks' to access the
-- predicates.
type CheckedDatabaseSettings be db = db (CheckedDatabaseEntity be db)

renameCheckedEntity :: (Text -> Text) -> EntityModification (CheckedDatabaseEntity be db) be ent
renameCheckedEntity renamer =
  EntityModification (Endo (\(CheckedDatabaseEntity desc checks) -> (CheckedDatabaseEntity (desc & unChecked . dbEntityName %~ renamer) checks)))

-- | Convert a 'CheckedDatabaseSettings' to a regular 'DatabaseSettings'. The
-- return value is suitable for use in any regular beam query or DML statement.
unCheckDatabase :: forall be db. Database be db => CheckedDatabaseSettings be db -> DatabaseSettings be db
unCheckDatabase db = runIdentity $ zipTables (Proxy @be) (\(CheckedDatabaseEntity x _) _ -> pure $ DatabaseEntity (unCheck x)) db db

unCheckedDbLens :: forall be db. Database be db => Lens' (CheckedDatabaseSettings be db) (DatabaseSettings be db)
unCheckedDbLens f db =
    (\db' -> runIdentity (zipTables (Proxy @be) (\(CheckedDatabaseEntity d cks) d' -> pure (CheckedDatabaseEntity (d & unChecked .~ (d' ^. dbEntityDescriptor)) cks)) db db')) <$> f (unCheckDatabase db)

-- | A @beam-migrate@ database schema is defined completely by the set of
-- predicates that apply to it. This function allows you to access this
-- definition for a 'CheckedDatabaseSettings' object.
collectChecks :: forall be db. Database be  db => CheckedDatabaseSettings be db -> [ SomeDatabasePredicate ]
collectChecks db = let (_ :: CheckedDatabaseSettings be db, a) =
                         runWriter $ zipTables (Proxy @be)
                           (\(CheckedDatabaseEntity entity cs :: CheckedDatabaseEntity be db entityType) b ->
                              do tell (collectEntityChecks entity)
                                 tell cs
                                 pure b) db db
                   in a

instance IsCheckedDatabaseEntity be (DomainTypeEntity ty) where
  data CheckedDatabaseEntityDescriptor be (DomainTypeEntity ty) =
    CheckedDatabaseDomainType (DatabaseEntityDescriptor be (DomainTypeEntity ty))
                              [ DomainCheck ]
  type CheckedDatabaseEntityDefaultRequirements be (DomainTypeEntity ty) =
    DatabaseEntityDefaultRequirements be (DomainTypeEntity ty)

  unChecked f (CheckedDatabaseDomainType x cks) = fmap (\x' -> CheckedDatabaseDomainType x' cks) (f x)
  collectEntityChecks (CheckedDatabaseDomainType dt domainChecks) =
    map (\(DomainCheck mkCheck) -> mkCheck (qname dt)) domainChecks
  checkedDbEntityAuto domTypeName =
    CheckedDatabaseDomainType (dbEntityAuto domTypeName) []

instance Beamable tbl => IsCheckedDatabaseEntity be (TableEntity tbl) where
  data CheckedDatabaseEntityDescriptor be (TableEntity tbl) where
    CheckedDatabaseTable :: Table tbl
                         => DatabaseEntityDescriptor be (TableEntity tbl)
                         -> [ TableCheck ]
                         -> tbl (Const [FieldCheck])
                         -> CheckedDatabaseEntityDescriptor be (TableEntity tbl)

  type CheckedDatabaseEntityDefaultRequirements be (TableEntity tbl)  =
    ( DatabaseEntityDefaultRequirements be (TableEntity tbl)
    , Generic (tbl (Const [FieldCheck]))
    , GMigratableTableSettings be (Rep (tbl Identity)) (Rep (tbl (Const [FieldCheck])))
    , BeamSqlBackend be )

  unChecked f (CheckedDatabaseTable x cks fcks) = fmap (\x' -> CheckedDatabaseTable x' cks fcks) (f x)
  collectEntityChecks (CheckedDatabaseTable dt tblChecks tblFieldChecks) =
    catMaybes (map (\(TableCheck mkCheck) -> mkCheck (qname dt) (dbTableSettings dt)) tblChecks) <>
    execWriter (zipBeamFieldsM (\(Columnar' fd) c@(Columnar' (Const fieldChecks)) ->
                                    tell (map (\(FieldCheck mkCheck) -> mkCheck (qname dt) (fd ^. fieldName)) fieldChecks) >>
                                    pure c)
                               (dbTableSettings dt) tblFieldChecks)

  checkedDbEntityAuto tblTypeName =
    let tblChecks =
          [ TableCheck $ \tblName _ ->
              Just (SomeDatabasePredicate (TableExistsPredicate tblName))
          , TableCheck $ \tblName tblFields ->
              case allBeamValues (\(Columnar' fd) -> fd ^. fieldName) (primaryKey tblFields) of
                [] -> Nothing
                pkFields -> Just (SomeDatabasePredicate (TableHasPrimaryKey tblName pkFields))
          ]

        fieldChecks = to (gDefaultTblSettingsChecks (Proxy @be) (Proxy @(Rep (tbl Identity))) False)
    in CheckedDatabaseTable (dbEntityAuto tblTypeName) tblChecks fieldChecks

-- | Purposefully opaque type describing how to modify a table field. Used to
-- parameterize the second argument to 'modifyCheckedTable'. For now, the only
-- way to construct a value is the 'IsString' instance, which allows you to
-- rename the field.
data CheckedFieldModification tbl a
  = CheckedFieldModification
      (TableField tbl a -> TableField tbl a)
      ([FieldCheck] -> [FieldCheck])

checkedFieldNamed :: Text -> CheckedFieldModification tbl a
checkedFieldNamed t = CheckedFieldModification (fieldName .~ t) id

instance IsString (CheckedFieldModification tbl a) where
  fromString = checkedFieldNamed . fromString

instance Beamable tbl => RenamableWithRule (tbl (CheckedFieldModification tbl)) where
  renamingFields renamer =
    runIdentity $
    zipBeamFieldsM (\(Columnar' _ :: Columnar' Ignored x) (Columnar' _ :: Columnar' Ignored x) ->
                       pure (Columnar' (CheckedFieldModification (renameField (Proxy @(TableField tbl)) (Proxy @x) renamer) id :: CheckedFieldModification tbl x) ::
                               Columnar' (CheckedFieldModification tbl) x))
                   (undefined :: TableSkeleton tbl) (undefined :: TableSkeleton tbl)

-- | Modify a checked table.
--
--   The first argument is a function that takes the original table name as
--   input and produces a new table name.
--
--   The second argument gives instructions on how to rename each field in the
--   table. Use 'checkedTableModification' to create a value of this type which
--   does no renaming. Each field in the table supplied here has the type
--   'CheckedFieldModification'. Most commonly, the programmer will use the
--   @OverloadedStrings@ instance to provide a new name.
--
-- == Examples
--
--    Rename a table, without renaming any of its fields:
--
-- @
-- modifyCheckedTable (\_ -> "NewTblNm") checkedTableModification
-- @
--
--    Modify a table, renaming the field called @_field1@ in Haskell to
--    "FirstName". Note that below, @"FirstName"@ represents a
--    'CheckedFieldModification' object.
--
-- @
-- modifyCheckedTable id (checkedTableModification { _field1 = "FirstName" })
-- @

modifyCheckedTable
  :: ( Text -> Text )
  -> tbl (CheckedFieldModification tbl)
  -> EntityModification (CheckedDatabaseEntity be db) be (TableEntity tbl)
modifyCheckedTable renamer modFields =
  EntityModification $ Endo $
  \(CheckedDatabaseEntity (CheckedDatabaseTable dt tblChecks fieldChecks) extraChecks) ->
    let fields' =
          runIdentity $
          zipBeamFieldsM (\(Columnar' (CheckedFieldModification fieldMod _)) (Columnar' field) ->
                             pure $ Columnar' (fieldMod field))
                         modFields (dbTableSettings dt)
        fieldChecks' =
          runIdentity $
          zipBeamFieldsM (\(Columnar' (CheckedFieldModification _ csMod)) (Columnar' (Const cs)) ->
                             pure $ Columnar' (Const (csMod cs)))
                         modFields fieldChecks
    in CheckedDatabaseEntity (CheckedDatabaseTable
                                (dt { dbTableCurrentName = renamer (dbTableCurrentName dt)
                                    , dbTableSettings = fields'})
                                tblChecks fieldChecks') extraChecks

-- | Lift a field accessor into a column-name reference, for use with
-- 'addTableIndex'.
--
-- See also 'foreignKeyColumns'.
selectorColumnName :: (tbl (TableField tbl) -> TableField tbl a)
         -> tbl (TableField tbl)
         -> Text
selectorColumnName f = (^. fieldName) . f

-- | Expand a foreign-key accessor into its constituent column-name references,
-- for use with 'addTableIndex'.
--
-- Example:
--
-- @
-- data UserT f = User
--   { userId   :: C f Int32
--   , userName :: C f Text
--   }
-- instance Table UserT where
--   newtype PrimaryKey UserT f = UserId (C f Int32)
--   primaryKey (User {userId = i}) = UserId i
-- data OrderT f = Order
--   { orderUser :: PrimaryKey UserT f
--   , orderDate :: C f Day
--   }
-- @
--
-- @
-- addTableIndex "idx_orders_user" indexOptions
--   (\\t -> foreignKeyColumns orderUser t)
-- @
--
-- Can be combined with 'selectorColumnName' for composite indices.
foreignKeyColumns :: Beamable (PrimaryKey ref)
                  => (tbl (TableField tbl) -> PrimaryKey ref (TableField tbl))
                  -> tbl (TableField tbl)
                  -> NE.NonEmpty Text
foreignKeyColumns f t =
  case NE.nonEmpty $ allBeamValues (\(Columnar' field) -> field ^. fieldName) pkey of
    Nothing -> error $ "foreignKeyColumns: foreign key has no fields"
    Just cols -> cols
  where
    pkey = f t

-- | Automatically extracts all column names from a table's primary key
primaryKeyColumns :: Table tbl => tbl (TableField tbl) -> NE.NonEmpty Text
primaryKeyColumns tbl =
  case NE.nonEmpty $ allBeamValues (\(Columnar' field) -> field ^. fieldName) (primaryKey tbl) of
    Nothing -> error "primaryKeyColumns: primary key has no fields"
    Just cols -> cols

-- | Declare a secondary index on a checked table entity.
--
-- Example:
--
-- @
-- addTableIndex "table_index" uniqueIndexOptions
--   (\\t -> selectorColumnName tableField1 t NE.:| [selectorColumnName tableField2 t])
-- @
addTableIndex :: forall be tbl db
              . ( Typeable be
                , IsSql92UniqueIndexSyntax (BeamSqlBackendSyntax be) )
              => Text                             -- ^ SQL index name
              -> BeamSqlBackendIndexSyntax be     -- ^ index options (e.g. 'nonUniqueIndexOptions', 'uniqueIndexOptions')
              -> (tbl (TableField tbl) -> NE.NonEmpty Text) -- ^ column names to index (use 'selectorColumnName')
              -> EntityModification (CheckedDatabaseEntity be db) be (TableEntity tbl)
addTableIndex idxNm opts getCols =
  EntityModification $ Endo $
  \(CheckedDatabaseEntity (CheckedDatabaseTable dt tblChecks fieldChecks) extraChecks) ->
    let cols    = getCols (dbTableSettings dt)
        idxCheck = TableCheck $ \ tblNm _flds ->
          Just (SomeDatabasePredicate (TableHasIndex tblNm idxNm cols opts :: TableHasIndex be))
    in CheckedDatabaseEntity (CheckedDatabaseTable dt (tblChecks ++ [idxCheck]) fieldChecks)
                             extraChecks

-- | Declare a foreign key constraint on a checked table entity.
--
-- Example referencing the primary key of a @UserT@ table:
--
-- @
-- addTableForeignKey (db ^. usersTable)
--   (\\ t -> selectorColumnName _postAuthorId t NE.:| [])
--   primaryKeyColumns
--   ForeignKeyNoAction    -- ON UPDATE action
--   ForeignKeyActionCascade -- ON DELETE action
-- @
addTableForeignKey
  :: forall be db localTbl refTbl.
     (Table localTbl, Table refTbl)
  => CheckedDatabaseEntity be db (TableEntity refTbl)         -- ^ referenced table
  -> (localTbl (TableField localTbl) -> NE.NonEmpty Text)     -- ^ local columns
  -> (refTbl (TableField refTbl) -> NE.NonEmpty Text)         -- ^ referenced columns
  -> ForeignKeyAction -- ^ ON UPDATE action
  -> ForeignKeyAction -- ^ ON DELETE action
  -> EntityModification (CheckedDatabaseEntity be db) be (TableEntity localTbl)
addTableForeignKey refTableEntity getLocalFk getRefFk onUpdate onDelete =
  EntityModification $ Endo $
  \(CheckedDatabaseEntity (CheckedDatabaseTable dt tblChecks fieldChecks) extraChecks) ->
    let
        CheckedDatabaseEntity (CheckedDatabaseTable refDt _ _) _ = refTableEntity
        refTableName = QualifiedName (dbTableSchema refDt) (dbTableCurrentName refDt)

        localCols = getLocalFk (dbTableSettings dt)
        refCols   = getRefFk (dbTableSettings refDt)

        fkCheck = TableCheck $ \tblNm _flds ->
          Just (SomeDatabasePredicate
                  (TableHasForeignKey tblNm localCols refTableName refCols onUpdate onDelete))

    in CheckedDatabaseEntity (CheckedDatabaseTable dt (tblChecks ++ [fkCheck]) fieldChecks)
                             extraChecks

-- | Produce a table field modification that does nothing
--
--   Most commonly supplied as the second argument to 'modifyCheckedTable' when
--   you just want to rename the table, not the fields.
checkedTableModification :: forall tbl. Beamable tbl => tbl (CheckedFieldModification tbl)
checkedTableModification =
  runIdentity $
  zipBeamFieldsM (\(Columnar' _ :: Columnar' Ignored x) (Columnar' _ :: Columnar' Ignored x) ->
                    pure (Columnar' (CheckedFieldModification id id :: CheckedFieldModification tbl x)))
                 (undefined :: TableSkeleton tbl) (undefined :: TableSkeleton tbl)