{-# 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
_ = forall entity. (entity -> entity) -> FieldRenamer entity
FieldRenamer 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) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Text
nm' -> 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 = 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
_ = forall extension.
IsPgExtension extension =>
Text
-> extension
-> DatabaseEntityDescriptor Postgres (PgExtensionEntity extension)
PgDatabaseExtension (forall extension.
IsPgExtension extension =>
Proxy extension -> Text
pgExtensionName (forall {k} (t :: k). Proxy t
Proxy @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) = forall extension.
DatabaseEntityDescriptor Postgres (PgExtensionEntity extension)
-> CheckedDatabaseEntityDescriptor
     Postgres (PgExtensionEntity extension)
CheckedPgExtension 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 {})) =
    [ forall p. DatabasePredicate p => p -> SomeDatabasePredicate
SomeDatabasePredicate (Text -> PgHasExtension
PgHasExtension (forall extension.
IsPgExtension extension =>
Proxy extension -> Text
pgExtensionName (forall {k} (t :: k). Proxy t
Proxy @extension))) ]
  checkedDbEntityAuto :: CheckedDatabaseEntityDefaultRequirements
  Postgres (PgExtensionEntity extension) =>
Text
-> CheckedDatabaseEntityDescriptor
     Postgres (PgExtensionEntity extension)
checkedDbEntityAuto = forall extension.
DatabaseEntityDescriptor Postgres (PgExtensionEntity extension)
-> CheckedDatabaseEntityDescriptor
     Postgres (PgExtensionEntity extension)
CheckedPgExtension forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall be entity.
(IsCheckedDatabaseEntity be entity,
 CheckedDatabaseEntityDefaultRequirements be entity) =>
Text -> CheckedDatabaseEntityDescriptor be entity
checkedDbEntityAuto Text
""
      extName :: Text
extName = forall extension.
IsPgExtension extension =>
Proxy extension -> Text
pgExtensionName (forall {k} (t :: k). Proxy t
Proxy @extension)
  in forall be.
BeamSqlBackendSyntax be
-> Maybe (BeamSqlBackendSyntax be) -> Migration be ()
upDown (Text -> PgCommandSyntax
pgCreateExtensionSyntax Text
extName) forall a. Maybe a
Nothing forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
     forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall be entityType (db :: (* -> *) -> *).
IsCheckedDatabaseEntity be entityType =>
CheckedDatabaseEntityDescriptor be entityType
-> [SomeDatabasePredicate]
-> CheckedDatabaseEntity be db entityType
CheckedDatabaseEntity CheckedDatabaseEntityDescriptor
  Postgres (PgExtensionEntity extension)
entity (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 {})) =
  forall be.
BeamSqlBackendSyntax be
-> Maybe (BeamSqlBackendSyntax be) -> Migration be ()
upDown (Text -> PgCommandSyntax
pgDropExtensionSyntax (forall extension.
IsPgExtension extension =>
Proxy extension -> Text
pgExtensionName (forall {k} (t :: k). Proxy t
Proxy @extension))) 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PgHasExtension] -> ShowS
$cshowList :: [PgHasExtension] -> ShowS
show :: PgHasExtension -> String
$cshow :: PgHasExtension -> String
showsPrec :: Int -> PgHasExtension -> ShowS
$cshowsPrec :: Int -> PgHasExtension -> ShowS
Show, PgHasExtension -> PgHasExtension -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PgHasExtension -> PgHasExtension -> Bool
$c/= :: PgHasExtension -> PgHasExtension -> Bool
== :: PgHasExtension -> PgHasExtension -> Bool
$c== :: PgHasExtension -> PgHasExtension -> Bool
Eq, 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
$cto :: forall x. Rep PgHasExtension x -> PgHasExtension
$cfrom :: forall x. PgHasExtension -> Rep PgHasExtension x
Generic, Eq PgHasExtension
Int -> PgHasExtension -> Int
PgHasExtension -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: PgHasExtension -> Int
$chash :: PgHasExtension -> Int
hashWithSalt :: Int -> PgHasExtension -> Int
$chashWithSalt :: Int -> PgHasExtension -> Int
Hashable)
instance DatabasePredicate PgHasExtension where
  englishDescription :: PgHasExtension -> String
englishDescription (PgHasExtension Text
extName) =
    String
"Postgres extension " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Text
extName 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" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
nm ]

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

pgCreateExtensionProvider, pgDropExtensionProvider :: ActionProvider Postgres

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

     let cmd :: PgCommandSyntax
cmd = Text -> PgCommandSyntax
pgCreateExtensionSyntax Text
ext
     forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall be.
HashSet SomeDatabasePredicate
-> HashSet SomeDatabasePredicate
-> Seq (MigrationCommand be)
-> Text
-> Int
-> PotentialAction be
PotentialAction forall a. Monoid a => a
mempty (forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList [forall p. DatabasePredicate p => p -> SomeDatabasePredicate
p PgHasExtension
extP])
                           (forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall be.
BeamSqlBackendSyntax be -> MigrationDataLoss -> MigrationCommand be
MigrationCommand PgCommandSyntax
cmd MigrationDataLoss
MigrationKeepsData))
                           (Text
"Load the postgres extension " forall a. Semigroup a => a -> a -> a
<> Text
ext) Int
1)

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

     let cmd :: PgCommandSyntax
cmd = Text -> PgCommandSyntax
pgDropExtensionSyntax Text
ext
     forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall be.
HashSet SomeDatabasePredicate
-> HashSet SomeDatabasePredicate
-> Seq (MigrationCommand be)
-> Text
-> Int
-> PotentialAction be
PotentialAction (forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList [forall p. DatabasePredicate p => p -> SomeDatabasePredicate
p PgHasExtension
extP]) forall a. Monoid a => a
mempty
                           (forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall be.
BeamSqlBackendSyntax be -> MigrationDataLoss -> MigrationCommand be
MigrationCommand PgCommandSyntax
cmd MigrationDataLoss
MigrationKeepsData))
                           (Text
"Unload the postgres extension " forall a. Semigroup a => a -> a -> a
<> Text
ext) Int
1)