{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE CPP #-}

-- | Postgres extensions are run-time loadable plugins that can extend Postgres
-- functionality. Extensions are part of the database schema.
--
-- Beam fully supports including Postgres extensions in Beam databases. The
-- 'PgExtensionEntity' type constructor can be used to declare the existence of
-- the extension in a particular backend. @beam-postgres@ provides predicates
-- and checks for @beam-migrate@ which allow extensions to be included as
-- regular parts of beam migrations.
module Database.Beam.Postgres.Extensions where

import           Database.Beam
import           Database.Beam.Schema.Tables

import           Database.Beam.Postgres.Types
import           Database.Beam.Postgres.Syntax

import           Database.Beam.Migrate

import           Control.Monad

import           Data.Aeson
import qualified Data.HashSet as HS
import           Data.Hashable (Hashable)
import           Data.Proxy
import           Data.Text (Text)
#if !MIN_VERSION_base(4, 11, 0)
import           Data.Semigroup
#endif

-- *** Embedding extensions in databases

-- | Represents an extension in a database.
--
-- For example, to include the "Database.Beam.Postgres.PgCrypto" extension in a
-- database,
--
-- @
-- import Database.Beam.Postgres.PgCrypto
--
-- data MyDatabase entity
--     = MyDatabase
--     { _table1 :: entity (TableEntity Table1)
--     , _cryptoExtension :: entity (PgExtensionEntity PgCrypto)
--     }
--
-- migratableDbSettings :: CheckedDatabaseSettings Postgres MyDatabase
-- migratableDbSettings = defaultMigratableDbSettings
--
-- dbSettings :: DatabaseSettings Postgres MyDatabase
-- dbSettings = unCheckDatabase migratableDbSettings
-- @
--
-- Note that our database now only works in the 'Postgres' backend.
--
-- Extensions are implemented as records of functions and values that expose
-- extension functionality. For example, the @pgcrypto@ extension (implemented
-- by 'PgCrypto') provides cryptographic functions. Thus, 'PgCrypto' is a record
-- of functions over 'QGenExpr' which wrap the underlying postgres
-- functionality.
--
-- You get access to these functions by retrieving them from the entity in the
-- database.
--
-- For example, to use the @pgcrypto@ extension in the database above:
--
-- @
-- let PgCrypto { pgCryptoDigestText = digestText
--              , pgCryptoCrypt = crypt } = getPgExtension (_cryptoExtension dbSettings)
-- in fmap_ (\tbl -> (tbl, crypt (_field1 tbl) (_salt tbl))) (all_ (table1 dbSettings))
-- @
--
-- To implement your own extension, create a record type, and implement the
-- 'IsPgExtension' type class.
data PgExtensionEntity extension

-- | Type class implemented by any Postgresql extension
class IsPgExtension extension where
  -- | Return the name of this extension. This should be the string that is
  -- passed to @CREATE EXTENSION@. For example, 'PgCrypto' returns @"pgcrypto"@.
  pgExtensionName :: Proxy extension -> Text

  -- | Return a value of this extension type. This should fill in all fields in
  -- the record. For example, 'PgCrypto' builds a record where each function
  -- wraps the underlying Postgres one.
  pgExtensionBuild :: extension

-- | There are no fields to rename when defining entities
instance RenamableWithRule (FieldRenamer (DatabaseEntityDescriptor Postgres (PgExtensionEntity e))) where
  renamingFields :: (NonEmpty Text -> Text)
-> FieldRenamer
     (DatabaseEntityDescriptor Postgres (PgExtensionEntity e))
renamingFields NonEmpty Text -> Text
_ = (DatabaseEntityDescriptor Postgres (PgExtensionEntity e)
 -> DatabaseEntityDescriptor Postgres (PgExtensionEntity e))
-> FieldRenamer
     (DatabaseEntityDescriptor Postgres (PgExtensionEntity e))
forall entity. (entity -> entity) -> FieldRenamer entity
FieldRenamer DatabaseEntityDescriptor Postgres (PgExtensionEntity e)
-> DatabaseEntityDescriptor Postgres (PgExtensionEntity e)
forall a. a -> a
id

instance IsDatabaseEntity Postgres (PgExtensionEntity extension) where

  data DatabaseEntityDescriptor Postgres (PgExtensionEntity extension) where
    PgDatabaseExtension :: IsPgExtension extension
                        => Text
                        -> extension
                        -> DatabaseEntityDescriptor Postgres (PgExtensionEntity extension)
  type DatabaseEntityDefaultRequirements Postgres (PgExtensionEntity extension) =
    ( IsPgExtension extension )
  type DatabaseEntityRegularRequirements Postgres (PgExtensionEntity extension) =
    ( IsPgExtension extension )

  dbEntityName :: Lens'
  (DatabaseEntityDescriptor Postgres (PgExtensionEntity extension))
  Text
dbEntityName Text -> f Text
f (PgDatabaseExtension Text
nm extension
ext) = (Text
 -> DatabaseEntityDescriptor Postgres (PgExtensionEntity extension))
-> f Text
-> f (DatabaseEntityDescriptor
        Postgres (PgExtensionEntity extension))
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Text
nm' -> Text
-> extension
-> DatabaseEntityDescriptor Postgres (PgExtensionEntity extension)
forall extension.
IsPgExtension extension =>
Text
-> extension
-> DatabaseEntityDescriptor Postgres (PgExtensionEntity extension)
PgDatabaseExtension Text
nm' extension
ext) (Text -> f Text
f Text
nm)
  dbEntitySchema :: Traversal'
  (DatabaseEntityDescriptor Postgres (PgExtensionEntity extension))
  (Maybe Text)
dbEntitySchema Maybe Text -> f (Maybe Text)
_ DatabaseEntityDescriptor Postgres (PgExtensionEntity extension)
n = DatabaseEntityDescriptor Postgres (PgExtensionEntity extension)
-> f (DatabaseEntityDescriptor
        Postgres (PgExtensionEntity extension))
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DatabaseEntityDescriptor Postgres (PgExtensionEntity extension)
n
  dbEntityAuto :: DatabaseEntityDefaultRequirements
  Postgres (PgExtensionEntity extension) =>
Text
-> DatabaseEntityDescriptor Postgres (PgExtensionEntity extension)
dbEntityAuto Text
_ = Text
-> extension
-> DatabaseEntityDescriptor Postgres (PgExtensionEntity extension)
forall extension.
IsPgExtension extension =>
Text
-> extension
-> DatabaseEntityDescriptor Postgres (PgExtensionEntity extension)
PgDatabaseExtension (Proxy extension -> Text
forall extension.
IsPgExtension extension =>
Proxy extension -> Text
pgExtensionName (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @extension)) extension
forall extension. IsPgExtension extension => extension
pgExtensionBuild

instance IsCheckedDatabaseEntity Postgres (PgExtensionEntity extension) where
  newtype CheckedDatabaseEntityDescriptor Postgres (PgExtensionEntity extension) =
    CheckedPgExtension (DatabaseEntityDescriptor Postgres (PgExtensionEntity extension))
  type CheckedDatabaseEntityDefaultRequirements Postgres (PgExtensionEntity extension) =
    DatabaseEntityRegularRequirements Postgres (PgExtensionEntity extension)

  unChecked :: Lens'
  (CheckedDatabaseEntityDescriptor
     Postgres (PgExtensionEntity extension))
  (DatabaseEntityDescriptor Postgres (PgExtensionEntity extension))
unChecked DatabaseEntityDescriptor Postgres (PgExtensionEntity extension)
-> f (DatabaseEntityDescriptor
        Postgres (PgExtensionEntity extension))
f (CheckedPgExtension DatabaseEntityDescriptor Postgres (PgExtensionEntity extension)
ext) = DatabaseEntityDescriptor Postgres (PgExtensionEntity extension)
-> CheckedDatabaseEntityDescriptor
     Postgres (PgExtensionEntity extension)
forall extension.
DatabaseEntityDescriptor Postgres (PgExtensionEntity extension)
-> CheckedDatabaseEntityDescriptor
     Postgres (PgExtensionEntity extension)
CheckedPgExtension (DatabaseEntityDescriptor Postgres (PgExtensionEntity extension)
 -> CheckedDatabaseEntityDescriptor
      Postgres (PgExtensionEntity extension))
-> f (DatabaseEntityDescriptor
        Postgres (PgExtensionEntity extension))
-> f (CheckedDatabaseEntityDescriptor
        Postgres (PgExtensionEntity extension))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DatabaseEntityDescriptor Postgres (PgExtensionEntity extension)
-> f (DatabaseEntityDescriptor
        Postgres (PgExtensionEntity extension))
f DatabaseEntityDescriptor Postgres (PgExtensionEntity extension)
ext
  collectEntityChecks :: CheckedDatabaseEntityDescriptor
  Postgres (PgExtensionEntity extension)
-> [SomeDatabasePredicate]
collectEntityChecks (CheckedPgExtension (PgDatabaseExtension {})) =
    [ PgHasExtension -> SomeDatabasePredicate
forall p. DatabasePredicate p => p -> SomeDatabasePredicate
SomeDatabasePredicate (Text -> PgHasExtension
PgHasExtension (Proxy extension -> Text
forall extension.
IsPgExtension extension =>
Proxy extension -> Text
pgExtensionName (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @extension))) ]
  checkedDbEntityAuto :: CheckedDatabaseEntityDefaultRequirements
  Postgres (PgExtensionEntity extension) =>
Text
-> CheckedDatabaseEntityDescriptor
     Postgres (PgExtensionEntity extension)
checkedDbEntityAuto = DatabaseEntityDescriptor Postgres (PgExtensionEntity extension)
-> CheckedDatabaseEntityDescriptor
     Postgres (PgExtensionEntity extension)
forall extension.
DatabaseEntityDescriptor Postgres (PgExtensionEntity extension)
-> CheckedDatabaseEntityDescriptor
     Postgres (PgExtensionEntity extension)
CheckedPgExtension (DatabaseEntityDescriptor Postgres (PgExtensionEntity extension)
 -> CheckedDatabaseEntityDescriptor
      Postgres (PgExtensionEntity extension))
-> (Text
    -> DatabaseEntityDescriptor Postgres (PgExtensionEntity extension))
-> Text
-> CheckedDatabaseEntityDescriptor
     Postgres (PgExtensionEntity extension)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text
-> DatabaseEntityDescriptor Postgres (PgExtensionEntity extension)
forall be entityType.
(IsDatabaseEntity be entityType,
 DatabaseEntityDefaultRequirements be entityType) =>
Text -> DatabaseEntityDescriptor be entityType
dbEntityAuto

-- | Get the extension record from a database entity. See the documentation for
-- 'PgExtensionEntity'.
getPgExtension :: DatabaseEntity Postgres db (PgExtensionEntity extension)
               -> extension
getPgExtension :: forall (db :: (* -> *) -> *) extension.
DatabaseEntity Postgres db (PgExtensionEntity extension)
-> extension
getPgExtension (DatabaseEntity (PgDatabaseExtension Text
_ extension
ext)) = extension
ext

-- *** Migrations support for extensions

-- | 'Migration' representing the Postgres @CREATE EXTENSION@ command. Because
-- the extension name is statically known by the extension type and
-- 'IsPgExtension' type class, this simply produces the checked extension
-- entity.
--
-- If you need to use the extension in subsequent migration steps, use
-- 'getPgExtension' and 'unCheck' to get access to the underlying
-- 'DatabaseEntity'.
pgCreateExtension :: forall extension db
                   . IsPgExtension extension
                  => Migration Postgres (CheckedDatabaseEntity Postgres db (PgExtensionEntity extension))
pgCreateExtension :: forall extension (db :: (* -> *) -> *).
IsPgExtension extension =>
Migration
  Postgres
  (CheckedDatabaseEntity Postgres db (PgExtensionEntity extension))
pgCreateExtension =
  let entity :: CheckedDatabaseEntityDescriptor
  Postgres (PgExtensionEntity extension)
entity = Text
-> CheckedDatabaseEntityDescriptor
     Postgres (PgExtensionEntity extension)
forall be entity.
(IsCheckedDatabaseEntity be entity,
 CheckedDatabaseEntityDefaultRequirements be entity) =>
Text -> CheckedDatabaseEntityDescriptor be entity
checkedDbEntityAuto Text
""
      extName :: Text
extName = Proxy extension -> Text
forall extension.
IsPgExtension extension =>
Proxy extension -> Text
pgExtensionName (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @extension)
  in BeamSqlBackendSyntax Postgres
-> Maybe (BeamSqlBackendSyntax Postgres) -> Migration Postgres ()
forall be.
BeamSqlBackendSyntax be
-> Maybe (BeamSqlBackendSyntax be) -> Migration be ()
upDown (Text -> PgCommandSyntax
pgCreateExtensionSyntax Text
extName) Maybe (BeamSqlBackendSyntax Postgres)
Maybe PgCommandSyntax
forall a. Maybe a
Nothing Migration Postgres ()
-> F (MigrationF Postgres)
     (CheckedDatabaseEntity Postgres db (PgExtensionEntity extension))
-> F (MigrationF Postgres)
     (CheckedDatabaseEntity Postgres db (PgExtensionEntity extension))
forall a b.
F (MigrationF Postgres) a
-> F (MigrationF Postgres) b -> F (MigrationF Postgres) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
     CheckedDatabaseEntity Postgres db (PgExtensionEntity extension)
-> F (MigrationF Postgres)
     (CheckedDatabaseEntity Postgres db (PgExtensionEntity extension))
forall a. a -> F (MigrationF Postgres) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CheckedDatabaseEntityDescriptor
  Postgres (PgExtensionEntity extension)
-> [SomeDatabasePredicate]
-> CheckedDatabaseEntity Postgres db (PgExtensionEntity extension)
forall be entityType (db :: (* -> *) -> *).
IsCheckedDatabaseEntity be entityType =>
CheckedDatabaseEntityDescriptor be entityType
-> [SomeDatabasePredicate]
-> CheckedDatabaseEntity be db entityType
CheckedDatabaseEntity CheckedDatabaseEntityDescriptor
  Postgres (PgExtensionEntity extension)
entity (CheckedDatabaseEntityDescriptor
  Postgres (PgExtensionEntity extension)
-> [SomeDatabasePredicate]
forall be entity.
IsCheckedDatabaseEntity be entity =>
CheckedDatabaseEntityDescriptor be entity
-> [SomeDatabasePredicate]
collectEntityChecks CheckedDatabaseEntityDescriptor
  Postgres (PgExtensionEntity extension)
entity))

-- | 'Migration' representing the Postgres @DROP EXTENSION@. After this
-- executes, you should expect any further uses of the extension to fail.
-- Unfortunately, without linear types, we cannot check this.
pgDropExtension :: forall extension
                 . CheckedDatabaseEntityDescriptor Postgres (PgExtensionEntity extension)
                -> Migration Postgres ()
pgDropExtension :: forall extension.
CheckedDatabaseEntityDescriptor
  Postgres (PgExtensionEntity extension)
-> Migration Postgres ()
pgDropExtension (CheckedPgExtension (PgDatabaseExtension {})) =
  BeamSqlBackendSyntax Postgres
-> Maybe (BeamSqlBackendSyntax Postgres) -> Migration Postgres ()
forall be.
BeamSqlBackendSyntax be
-> Maybe (BeamSqlBackendSyntax be) -> Migration be ()
upDown (Text -> PgCommandSyntax
pgDropExtensionSyntax (Proxy extension -> Text
forall extension.
IsPgExtension extension =>
Proxy extension -> Text
pgExtensionName (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @extension))) Maybe (BeamSqlBackendSyntax Postgres)
Maybe PgCommandSyntax
forall a. Maybe a
Nothing


-- | Postgres-specific database predicate asserting the existence of an
-- extension in the database. The 'pgExtensionActionProvider' properly provides
-- @CREATE EXTENSION@ and @DROP EXTENSION@ statements to the migration finder.
newtype PgHasExtension = PgHasExtension Text {- Extension Name -}
  deriving (Int -> PgHasExtension -> ShowS
[PgHasExtension] -> ShowS
PgHasExtension -> String
(Int -> PgHasExtension -> ShowS)
-> (PgHasExtension -> String)
-> ([PgHasExtension] -> ShowS)
-> Show PgHasExtension
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PgHasExtension -> ShowS
showsPrec :: Int -> PgHasExtension -> ShowS
$cshow :: PgHasExtension -> String
show :: PgHasExtension -> String
$cshowList :: [PgHasExtension] -> ShowS
showList :: [PgHasExtension] -> ShowS
Show, PgHasExtension -> PgHasExtension -> Bool
(PgHasExtension -> PgHasExtension -> Bool)
-> (PgHasExtension -> PgHasExtension -> Bool) -> Eq PgHasExtension
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PgHasExtension -> PgHasExtension -> Bool
== :: PgHasExtension -> PgHasExtension -> Bool
$c/= :: PgHasExtension -> PgHasExtension -> Bool
/= :: PgHasExtension -> PgHasExtension -> Bool
Eq, (forall x. PgHasExtension -> Rep PgHasExtension x)
-> (forall x. Rep PgHasExtension x -> PgHasExtension)
-> Generic PgHasExtension
forall x. Rep PgHasExtension x -> PgHasExtension
forall x. PgHasExtension -> Rep PgHasExtension x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. PgHasExtension -> Rep PgHasExtension x
from :: forall x. PgHasExtension -> Rep PgHasExtension x
$cto :: forall x. Rep PgHasExtension x -> PgHasExtension
to :: forall x. Rep PgHasExtension x -> PgHasExtension
Generic, Eq PgHasExtension
Eq PgHasExtension =>
(Int -> PgHasExtension -> Int)
-> (PgHasExtension -> Int) -> Hashable PgHasExtension
Int -> PgHasExtension -> Int
PgHasExtension -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> PgHasExtension -> Int
hashWithSalt :: Int -> PgHasExtension -> Int
$chash :: PgHasExtension -> Int
hash :: PgHasExtension -> Int
Hashable)
instance DatabasePredicate PgHasExtension where
  englishDescription :: PgHasExtension -> String
englishDescription (PgHasExtension Text
extName) =
    String
"Postgres extension " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
extName String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is loaded"

  predicateSpecificity :: forall (proxy :: * -> *).
proxy PgHasExtension -> PredicateSpecificity
predicateSpecificity proxy PgHasExtension
_ = String -> PredicateSpecificity
PredicateSpecificityOnlyBackend String
"postgres"
  serializePredicate :: PgHasExtension -> Value
serializePredicate (PgHasExtension Text
nm) =
    [Pair] -> Value
object [ Key
"has-postgres-extension" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
nm ]

pgExtensionActionProvider :: ActionProvider Postgres
pgExtensionActionProvider :: ActionProvider Postgres
pgExtensionActionProvider = ActionProvider Postgres
pgCreateExtensionProvider ActionProvider Postgres
-> ActionProvider Postgres -> ActionProvider Postgres
forall a. Semigroup a => a -> a -> a
<> ActionProvider Postgres
pgDropExtensionProvider

pgCreateExtensionProvider, pgDropExtensionProvider :: ActionProvider Postgres

pgCreateExtensionProvider :: ActionProvider Postgres
pgCreateExtensionProvider =
  ActionProviderFn Postgres -> ActionProvider Postgres
forall be. ActionProviderFn be -> ActionProvider be
ActionProvider (ActionProviderFn Postgres -> ActionProvider Postgres)
-> ActionProviderFn Postgres -> ActionProvider Postgres
forall a b. (a -> b) -> a -> b
$ \forall preCondition. Typeable preCondition => [preCondition]
findPre forall preCondition. Typeable preCondition => [preCondition]
findPost ->
  do extP@(PgHasExtension ext) <- [PgHasExtension]
forall preCondition. Typeable preCondition => [preCondition]
findPost
     ensuringNot_ $
       do PgHasExtension ext' <- findPre
          guard (ext == ext')

     let cmd = Text -> PgCommandSyntax
pgCreateExtensionSyntax Text
ext
     pure (PotentialAction mempty (HS.fromList [p extP])
                           (pure (MigrationCommand cmd MigrationKeepsData))
                           ("Load the postgres extension " <> ext) 1)

pgDropExtensionProvider :: ActionProvider Postgres
pgDropExtensionProvider =
  ActionProviderFn Postgres -> ActionProvider Postgres
forall be. ActionProviderFn be -> ActionProvider be
ActionProvider (ActionProviderFn Postgres -> ActionProvider Postgres)
-> ActionProviderFn Postgres -> ActionProvider Postgres
forall a b. (a -> b) -> a -> b
$ \forall preCondition. Typeable preCondition => [preCondition]
findPre forall preCondition. Typeable preCondition => [preCondition]
findPost ->
  do extP@(PgHasExtension ext) <- [PgHasExtension]
forall preCondition. Typeable preCondition => [preCondition]
findPre
     ensuringNot_ $
       do PgHasExtension ext' <- findPost
          guard (ext == ext')

     let cmd = Text -> PgCommandSyntax
pgDropExtensionSyntax Text
ext
     pure (PotentialAction (HS.fromList [p extP]) mempty
                           (pure (MigrationCommand cmd MigrationKeepsData))
                           ("Unload the postgres extension " <> ext) 1)