-- |
-- Module: Database.PostgreSQL.PQTypes.Model.Trigger
--
-- Trigger name must be unique among triggers of the same table.
--
-- For details, see <https://www.postgresql.org/docs/current/sql-createtrigger.html>.
module Database.PostgreSQL.PQTypes.Model.Trigger
  ( -- * Triggers
    TriggerKind (..)
  , TriggerActionTime (..)
  , TriggerEvent (..)
  , Trigger (..)
  , triggerMakeName
  , triggerBaseName
  , sqlCreateTrigger
  , sqlDropTrigger
  , createTrigger
  , dropTrigger
  , getDBTriggers

    -- * Trigger functions
  , sqlCreateTriggerFunction
  , sqlDropTriggerFunction
  , triggerFunctionMakeName

    -- * Constraints
  , ConstraintAttributes (..)
  ) where

import Data.Bits (testBit)
import Data.Foldable (foldl')
import Data.Int
import Data.Monoid.Utils
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Text qualified as Text
import Database.PostgreSQL.PQTypes
import Database.PostgreSQL.PQTypes.SQL.Builder

-- | Timing for a regular trigger.
--
-- @since 1.17.0.0
data TriggerActionTime
  = -- | An @AFTER@ trigger.
    After
  | -- | A @BEFORE@ trigger.
    Before
  deriving (TriggerActionTime -> TriggerActionTime -> Bool
(TriggerActionTime -> TriggerActionTime -> Bool)
-> (TriggerActionTime -> TriggerActionTime -> Bool)
-> Eq TriggerActionTime
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TriggerActionTime -> TriggerActionTime -> Bool
== :: TriggerActionTime -> TriggerActionTime -> Bool
$c/= :: TriggerActionTime -> TriggerActionTime -> Bool
/= :: TriggerActionTime -> TriggerActionTime -> Bool
Eq, Int -> TriggerActionTime -> ShowS
[TriggerActionTime] -> ShowS
TriggerActionTime -> String
(Int -> TriggerActionTime -> ShowS)
-> (TriggerActionTime -> String)
-> ([TriggerActionTime] -> ShowS)
-> Show TriggerActionTime
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TriggerActionTime -> ShowS
showsPrec :: Int -> TriggerActionTime -> ShowS
$cshow :: TriggerActionTime -> String
show :: TriggerActionTime -> String
$cshowList :: [TriggerActionTime] -> ShowS
showList :: [TriggerActionTime] -> ShowS
Show)

-- | Possible combinations of constraint attributes.
--
-- @since 1.17.0.0
data ConstraintAttributes
  = -- | The @NOT DEFERRABLE [INITIALLY IMMEDIATE]@ constraint.
    -- A @NOT DEFERRABLE@ constraint is @INITIALLY IMMEDIATE@ by default.
    NotDeferrable
  | -- | The @DEFERRABLE [INITIALLY IMMEDIATE]@ constraint.
    -- A @DEFERRABLE@ constraint is @INITIALLY IMMEDIATE@ by default.
    Deferrable
  | -- | The @DEFERRABLE INITIALLY DEFERRED@ constraint.
    DeferrableInitiallyDeferred
  deriving (ConstraintAttributes -> ConstraintAttributes -> Bool
(ConstraintAttributes -> ConstraintAttributes -> Bool)
-> (ConstraintAttributes -> ConstraintAttributes -> Bool)
-> Eq ConstraintAttributes
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ConstraintAttributes -> ConstraintAttributes -> Bool
== :: ConstraintAttributes -> ConstraintAttributes -> Bool
$c/= :: ConstraintAttributes -> ConstraintAttributes -> Bool
/= :: ConstraintAttributes -> ConstraintAttributes -> Bool
Eq, Int -> ConstraintAttributes -> ShowS
[ConstraintAttributes] -> ShowS
ConstraintAttributes -> String
(Int -> ConstraintAttributes -> ShowS)
-> (ConstraintAttributes -> String)
-> ([ConstraintAttributes] -> ShowS)
-> Show ConstraintAttributes
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ConstraintAttributes -> ShowS
showsPrec :: Int -> ConstraintAttributes -> ShowS
$cshow :: ConstraintAttributes -> String
show :: ConstraintAttributes -> String
$cshowList :: [ConstraintAttributes] -> ShowS
showList :: [ConstraintAttributes] -> ShowS
Show)

-- | Trigger kind.
--
-- @since 1.17.0.0
data TriggerKind
  = -- | Create a regular trigger: @CREATE TRIGGER@
    TriggerRegular TriggerActionTime
  | -- | Create a constraint trigger: @CREATE CONSTRAINT TRIGGER@
    TriggerConstraint ConstraintAttributes
  deriving (TriggerKind -> TriggerKind -> Bool
(TriggerKind -> TriggerKind -> Bool)
-> (TriggerKind -> TriggerKind -> Bool) -> Eq TriggerKind
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TriggerKind -> TriggerKind -> Bool
== :: TriggerKind -> TriggerKind -> Bool
$c/= :: TriggerKind -> TriggerKind -> Bool
/= :: TriggerKind -> TriggerKind -> Bool
Eq, Int -> TriggerKind -> ShowS
[TriggerKind] -> ShowS
TriggerKind -> String
(Int -> TriggerKind -> ShowS)
-> (TriggerKind -> String)
-> ([TriggerKind] -> ShowS)
-> Show TriggerKind
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TriggerKind -> ShowS
showsPrec :: Int -> TriggerKind -> ShowS
$cshow :: TriggerKind -> String
show :: TriggerKind -> String
$cshowList :: [TriggerKind] -> ShowS
showList :: [TriggerKind] -> ShowS
Show)

-- | Trigger event name.
--
-- @since 1.15.0.0
data TriggerEvent
  = -- | The @INSERT@ event.
    TriggerInsert
  | -- | The @UPDATE@ event.
    TriggerUpdate
  | -- | The @UPDATE OF column1 [, column2 ...]@ event.
    TriggerUpdateOf [RawSQL ()]
  | -- | The @DELETE@ event.
    TriggerDelete
  deriving (TriggerEvent -> TriggerEvent -> Bool
(TriggerEvent -> TriggerEvent -> Bool)
-> (TriggerEvent -> TriggerEvent -> Bool) -> Eq TriggerEvent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TriggerEvent -> TriggerEvent -> Bool
== :: TriggerEvent -> TriggerEvent -> Bool
$c/= :: TriggerEvent -> TriggerEvent -> Bool
/= :: TriggerEvent -> TriggerEvent -> Bool
Eq, Eq TriggerEvent
Eq TriggerEvent =>
(TriggerEvent -> TriggerEvent -> Ordering)
-> (TriggerEvent -> TriggerEvent -> Bool)
-> (TriggerEvent -> TriggerEvent -> Bool)
-> (TriggerEvent -> TriggerEvent -> Bool)
-> (TriggerEvent -> TriggerEvent -> Bool)
-> (TriggerEvent -> TriggerEvent -> TriggerEvent)
-> (TriggerEvent -> TriggerEvent -> TriggerEvent)
-> Ord TriggerEvent
TriggerEvent -> TriggerEvent -> Bool
TriggerEvent -> TriggerEvent -> Ordering
TriggerEvent -> TriggerEvent -> TriggerEvent
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: TriggerEvent -> TriggerEvent -> Ordering
compare :: TriggerEvent -> TriggerEvent -> Ordering
$c< :: TriggerEvent -> TriggerEvent -> Bool
< :: TriggerEvent -> TriggerEvent -> Bool
$c<= :: TriggerEvent -> TriggerEvent -> Bool
<= :: TriggerEvent -> TriggerEvent -> Bool
$c> :: TriggerEvent -> TriggerEvent -> Bool
> :: TriggerEvent -> TriggerEvent -> Bool
$c>= :: TriggerEvent -> TriggerEvent -> Bool
>= :: TriggerEvent -> TriggerEvent -> Bool
$cmax :: TriggerEvent -> TriggerEvent -> TriggerEvent
max :: TriggerEvent -> TriggerEvent -> TriggerEvent
$cmin :: TriggerEvent -> TriggerEvent -> TriggerEvent
min :: TriggerEvent -> TriggerEvent -> TriggerEvent
Ord, Int -> TriggerEvent -> ShowS
[TriggerEvent] -> ShowS
TriggerEvent -> String
(Int -> TriggerEvent -> ShowS)
-> (TriggerEvent -> String)
-> ([TriggerEvent] -> ShowS)
-> Show TriggerEvent
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TriggerEvent -> ShowS
showsPrec :: Int -> TriggerEvent -> ShowS
$cshow :: TriggerEvent -> String
show :: TriggerEvent -> String
$cshowList :: [TriggerEvent] -> ShowS
showList :: [TriggerEvent] -> ShowS
Show)

-- | Trigger.
--
-- @since 1.15.0.0
data Trigger = Trigger
  { Trigger -> RawSQL ()
triggerTable :: RawSQL ()
  -- ^ The table that the trigger is associated with.
  , Trigger -> RawSQL ()
triggerName :: RawSQL ()
  -- ^ The internal name without any prefixes. Trigger name must be unique among
  -- triggers of same table. See 'triggerMakeName'.
  , Trigger -> TriggerKind
triggerKind :: TriggerKind
  -- ^ The kind of trigger we want to create.
  -- @since 1.17.0.0
  , Trigger -> Set TriggerEvent
triggerEvents :: Set TriggerEvent
  -- ^ The set of events. Corresponds to the @{ __event__ [ OR ... ] }@ in the trigger
  -- definition. The order in which they are defined doesn't matter and there can
  -- only be one of each.
  , Trigger -> Maybe (RawSQL ())
triggerWhen :: Maybe (RawSQL ())
  -- ^ The condition that specifies whether the trigger should fire. Corresponds to the
  -- @WHEN ( __condition__ )@ in the trigger definition.
  , Trigger -> RawSQL ()
triggerFunction :: RawSQL ()
  -- ^ The function to execute when the trigger fires.
  -- The function is declared as taking no arguments and returning type @trigger@.
  }
  deriving (Int -> Trigger -> ShowS
[Trigger] -> ShowS
Trigger -> String
(Int -> Trigger -> ShowS)
-> (Trigger -> String) -> ([Trigger] -> ShowS) -> Show Trigger
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Trigger -> ShowS
showsPrec :: Int -> Trigger -> ShowS
$cshow :: Trigger -> String
show :: Trigger -> String
$cshowList :: [Trigger] -> ShowS
showList :: [Trigger] -> ShowS
Show)

instance Eq Trigger where
  Trigger
t1 == :: Trigger -> Trigger -> Bool
== Trigger
t2 =
    Trigger -> RawSQL ()
triggerTable Trigger
t1 RawSQL () -> RawSQL () -> Bool
forall a. Eq a => a -> a -> Bool
== Trigger -> RawSQL ()
triggerTable Trigger
t2
      Bool -> Bool -> Bool
&& Trigger -> RawSQL ()
triggerName Trigger
t1 RawSQL () -> RawSQL () -> Bool
forall a. Eq a => a -> a -> Bool
== Trigger -> RawSQL ()
triggerName Trigger
t2
      Bool -> Bool -> Bool
&& Trigger -> TriggerKind
triggerKind Trigger
t1 TriggerKind -> TriggerKind -> Bool
forall a. Eq a => a -> a -> Bool
== Trigger -> TriggerKind
triggerKind Trigger
t2
      Bool -> Bool -> Bool
&& Trigger -> Set TriggerEvent
triggerEvents Trigger
t1 Set TriggerEvent -> Set TriggerEvent -> Bool
forall a. Eq a => a -> a -> Bool
== Trigger -> Set TriggerEvent
triggerEvents Trigger
t2
      Bool -> Bool -> Bool
&& Trigger -> Maybe (RawSQL ())
triggerWhen Trigger
t1 Maybe (RawSQL ()) -> Maybe (RawSQL ()) -> Bool
forall a. Eq a => a -> a -> Bool
== Trigger -> Maybe (RawSQL ())
triggerWhen Trigger
t2

-- Function source code is not guaranteed to be equal, so we ignore it.

-- | Make a trigger name that can be used in SQL.
--
-- Given a base @name@ and @tableName@, return a new name that will be used as the
-- actual name of the trigger in an SQL query. The returned name is in the format
-- @trg\__\<tableName\>\__\<name\>@.
--
-- @since 1.15.0
triggerMakeName :: RawSQL () -> RawSQL () -> RawSQL ()
triggerMakeName :: RawSQL () -> RawSQL () -> RawSQL ()
triggerMakeName RawSQL ()
name RawSQL ()
tableName = RawSQL ()
"trg__" RawSQL () -> RawSQL () -> RawSQL ()
forall a. Semigroup a => a -> a -> a
<> RawSQL ()
tableName RawSQL () -> RawSQL () -> RawSQL ()
forall a. Semigroup a => a -> a -> a
<> RawSQL ()
"__" RawSQL () -> RawSQL () -> RawSQL ()
forall a. Semigroup a => a -> a -> a
<> RawSQL ()
name

-- | Return the trigger's base name.
--
-- Given the trigger's actual @name@ and @tableName@, return the base name of the
-- trigger. This is basically the reverse of what 'triggerMakeName' does.
--
-- @since 1.15.0
triggerBaseName :: RawSQL () -> RawSQL () -> RawSQL ()
triggerBaseName :: RawSQL () -> RawSQL () -> RawSQL ()
triggerBaseName RawSQL ()
name RawSQL ()
tableName =
  Text -> () -> RawSQL ()
forall row. (Show row, ToRow row) => Text -> row -> RawSQL row
rawSQL ((Text, Text) -> Text
forall a b. (a, b) -> b
snd ((Text, Text) -> Text) -> (Text -> (Text, Text)) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
Text.breakOnEnd (RawSQL () -> Text
unRawSQL RawSQL ()
tableName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"__") (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ RawSQL () -> Text
unRawSQL RawSQL ()
name) ()

triggerEventName :: TriggerEvent -> RawSQL ()
triggerEventName :: TriggerEvent -> RawSQL ()
triggerEventName = \case
  TriggerEvent
TriggerInsert -> RawSQL ()
"INSERT"
  TriggerEvent
TriggerUpdate -> RawSQL ()
"UPDATE"
  TriggerUpdateOf [RawSQL ()]
columns ->
    if [RawSQL ()] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RawSQL ()]
columns
      then String -> RawSQL ()
forall a. HasCallStack => String -> a
error String
"UPDATE OF must have columns."
      else RawSQL ()
"UPDATE OF" RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL () -> [RawSQL ()] -> RawSQL ()
forall m. Monoid m => m -> [m] -> m
mintercalate RawSQL ()
", " [RawSQL ()]
columns
  TriggerEvent
TriggerDelete -> RawSQL ()
"DELETE"

-- | Build an SQL statement that creates a trigger.
--
-- @since 1.15.0
sqlCreateTrigger :: Trigger -> RawSQL ()
sqlCreateTrigger :: Trigger -> RawSQL ()
sqlCreateTrigger Trigger {Maybe (RawSQL ())
Set TriggerEvent
RawSQL ()
TriggerKind
triggerTable :: Trigger -> RawSQL ()
triggerName :: Trigger -> RawSQL ()
triggerKind :: Trigger -> TriggerKind
triggerEvents :: Trigger -> Set TriggerEvent
triggerWhen :: Trigger -> Maybe (RawSQL ())
triggerFunction :: Trigger -> RawSQL ()
triggerTable :: RawSQL ()
triggerName :: RawSQL ()
triggerKind :: TriggerKind
triggerEvents :: Set TriggerEvent
triggerWhen :: Maybe (RawSQL ())
triggerFunction :: RawSQL ()
..} =
  RawSQL ()
"CREATE"
    RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
trgKind
    RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
trgName
    RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
tgrActionTime
    RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
trgEvents
    RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
"ON"
    RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
triggerTable
    RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
trgConstraintAttributes
    RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
"FOR EACH ROW"
    RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
trgWhen
    RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
"EXECUTE FUNCTION"
    RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
trgFunction
    RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
"()"
  where
    trgKind :: RawSQL ()
trgKind = case TriggerKind
triggerKind of
      TriggerRegular TriggerActionTime
_ -> RawSQL ()
"TRIGGER"
      TriggerConstraint ConstraintAttributes
_ -> RawSQL ()
"CONSTRAINT TRIGGER"
    trgName :: RawSQL ()
trgName
      | RawSQL ()
triggerName RawSQL () -> RawSQL () -> Bool
forall a. Eq a => a -> a -> Bool
== RawSQL ()
"" = String -> RawSQL ()
forall a. HasCallStack => String -> a
error String
"Trigger must have a name."
      | Bool
otherwise = RawSQL () -> RawSQL () -> RawSQL ()
triggerMakeName RawSQL ()
triggerName RawSQL ()
triggerTable
    tgrActionTime :: RawSQL ()
tgrActionTime = case TriggerKind
triggerKind of
      TriggerRegular TriggerActionTime
After -> RawSQL ()
"AFTER"
      TriggerRegular TriggerActionTime
Before -> RawSQL ()
"BEFORE"
      TriggerConstraint ConstraintAttributes
_ -> RawSQL ()
"AFTER"
    trgEvents :: RawSQL ()
trgEvents
      | Set TriggerEvent
triggerEvents Set TriggerEvent -> Set TriggerEvent -> Bool
forall a. Eq a => a -> a -> Bool
== Set TriggerEvent
forall a. Set a
Set.empty = String -> RawSQL ()
forall a. HasCallStack => String -> a
error String
"Trigger must have at least one event."
      | Bool
otherwise = RawSQL () -> [RawSQL ()] -> RawSQL ()
forall m. Monoid m => m -> [m] -> m
mintercalate RawSQL ()
" OR " ([RawSQL ()] -> RawSQL ())
-> ([TriggerEvent] -> [RawSQL ()]) -> [TriggerEvent] -> RawSQL ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TriggerEvent -> RawSQL ()) -> [TriggerEvent] -> [RawSQL ()]
forall a b. (a -> b) -> [a] -> [b]
map TriggerEvent -> RawSQL ()
triggerEventName ([TriggerEvent] -> RawSQL ()) -> [TriggerEvent] -> RawSQL ()
forall a b. (a -> b) -> a -> b
$ Set TriggerEvent -> [TriggerEvent]
forall a. Set a -> [a]
Set.toList Set TriggerEvent
triggerEvents
    trgConstraintAttributes :: RawSQL ()
trgConstraintAttributes = case TriggerKind
triggerKind of
      TriggerRegular TriggerActionTime
_ -> RawSQL ()
""
      TriggerConstraint ConstraintAttributes
NotDeferrable -> RawSQL ()
"NOT DEFERRABLE"
      TriggerConstraint ConstraintAttributes
Deferrable -> RawSQL ()
"DEFERRABLE"
      TriggerConstraint ConstraintAttributes
DeferrableInitiallyDeferred -> RawSQL ()
"DEFERRABLE INITIALLY DEFERRED"
    trgWhen :: RawSQL ()
trgWhen = RawSQL ()
-> (RawSQL () -> RawSQL ()) -> Maybe (RawSQL ()) -> RawSQL ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe RawSQL ()
"" (\RawSQL ()
w -> RawSQL ()
"WHEN (" RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
w RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
")") Maybe (RawSQL ())
triggerWhen
    trgFunction :: RawSQL ()
trgFunction = RawSQL () -> RawSQL ()
triggerFunctionMakeName RawSQL ()
triggerName

-- | Build an SQL statement that drops a trigger.
--
-- @since 1.15.0
sqlDropTrigger :: Trigger -> RawSQL ()
sqlDropTrigger :: Trigger -> RawSQL ()
sqlDropTrigger Trigger {Maybe (RawSQL ())
Set TriggerEvent
RawSQL ()
TriggerKind
triggerTable :: Trigger -> RawSQL ()
triggerName :: Trigger -> RawSQL ()
triggerKind :: Trigger -> TriggerKind
triggerEvents :: Trigger -> Set TriggerEvent
triggerWhen :: Trigger -> Maybe (RawSQL ())
triggerFunction :: Trigger -> RawSQL ()
triggerTable :: RawSQL ()
triggerName :: RawSQL ()
triggerKind :: TriggerKind
triggerEvents :: Set TriggerEvent
triggerWhen :: Maybe (RawSQL ())
triggerFunction :: RawSQL ()
..} =
  -- In theory, because the trigger is dependent on its function, it should be enough to
  -- 'DROP FUNCTION triggerFunction CASCADE'. However, let's make this safe and go with
  -- the default RESTRICT here.
  RawSQL ()
"DROP TRIGGER" RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
trgName RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
"ON" RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
triggerTable RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
"RESTRICT"
  where
    trgName :: RawSQL ()
trgName
      | RawSQL ()
triggerName RawSQL () -> RawSQL () -> Bool
forall a. Eq a => a -> a -> Bool
== RawSQL ()
"" = String -> RawSQL ()
forall a. HasCallStack => String -> a
error String
"Trigger must have a name."
      | Bool
otherwise = RawSQL () -> RawSQL () -> RawSQL ()
triggerMakeName RawSQL ()
triggerName RawSQL ()
triggerTable

-- | Create the trigger in the database.
--
-- First, create the trigger's associated function, then create the trigger itself.
--
-- @since 1.15.0
createTrigger :: MonadDB m => Trigger -> m ()
createTrigger :: forall (m :: * -> *). MonadDB m => Trigger -> m ()
createTrigger Trigger
trigger = do
  -- TODO: Use 'withTransaction' here? That would mean adding MonadMask...
  RawSQL () -> m ()
forall sql (m :: * -> *).
(HasCallStack, IsSQL sql, MonadDB m) =>
sql -> m ()
runQuery_ (RawSQL () -> m ()) -> RawSQL () -> m ()
forall a b. (a -> b) -> a -> b
$ Trigger -> RawSQL ()
sqlCreateTriggerFunction Trigger
trigger
  RawSQL () -> m ()
forall sql (m :: * -> *).
(HasCallStack, IsSQL sql, MonadDB m) =>
sql -> m ()
runQuery_ (RawSQL () -> m ()) -> RawSQL () -> m ()
forall a b. (a -> b) -> a -> b
$ Trigger -> RawSQL ()
sqlCreateTrigger Trigger
trigger

-- | Drop the trigger from the database.
--
-- @since 1.15.0
dropTrigger :: MonadDB m => Trigger -> m ()
dropTrigger :: forall (m :: * -> *). MonadDB m => Trigger -> m ()
dropTrigger Trigger
trigger = do
  -- First, drop the trigger, as it is dependent on the function. See the comment in
  -- 'sqlDropTrigger'.
  -- TODO: Use 'withTransaction' here? That would mean adding MonadMask...
  RawSQL () -> m ()
forall sql (m :: * -> *).
(HasCallStack, IsSQL sql, MonadDB m) =>
sql -> m ()
runQuery_ (RawSQL () -> m ()) -> RawSQL () -> m ()
forall a b. (a -> b) -> a -> b
$ Trigger -> RawSQL ()
sqlDropTrigger Trigger
trigger
  RawSQL () -> m ()
forall sql (m :: * -> *).
(HasCallStack, IsSQL sql, MonadDB m) =>
sql -> m ()
runQuery_ (RawSQL () -> m ()) -> RawSQL () -> m ()
forall a b. (a -> b) -> a -> b
$ Trigger -> RawSQL ()
sqlDropTriggerFunction Trigger
trigger

-- | Get all noninternal triggers from the database.
--
-- Run a query that returns all triggers associated with the given table and marked as
-- @tgisinternal = false@. The second item in the returned tuple is the trigger's function
-- name.
--
-- Note that, in the background, to get the trigger's @WHEN@ clause and the source code of
-- the attached function, the entire query that had created the trigger is received using
-- @pg_get_triggerdef(t.oid, true)::text@ and then parsed. The result of that call will be
-- decompiled and normalized, which means that it's likely not what the user had
-- originally typed.
--
-- @since 1.15.0
getDBTriggers :: forall m. MonadDB m => RawSQL () -> m [(Trigger, RawSQL ())]
getDBTriggers :: forall (m :: * -> *).
MonadDB m =>
RawSQL () -> m [(Trigger, RawSQL ())]
getDBTriggers RawSQL ()
tableName = do
  SqlSelect -> m ()
forall sql (m :: * -> *).
(HasCallStack, IsSQL sql, MonadDB m) =>
sql -> m ()
runQuery_ (SqlSelect -> m ())
-> (State SqlSelect () -> SqlSelect) -> State SqlSelect () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> State SqlSelect () -> SqlSelect
sqlSelect SQL
"pg_trigger t" (State SqlSelect () -> m ()) -> State SqlSelect () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"t.tgname::text" -- name
    SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"t.tgtype" -- smallint == int2 => (2 bytes)
    SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"t.tgconstraint > 0" -- we only check if CONSTRAINT has been specified
    SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"t.tgdeferrable" -- boolean
    SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"t.tginitdeferred" -- boolean
    -- This gets the entire query that created this trigger. Note that it's decompiled and
    -- normalized, which means that it's likely not what the user actually typed. For
    -- example, if the original query had excessive whitespace in it, it won't be in this
    -- result.
    SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"pg_get_triggerdef(t.oid, true)::text"
    SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"p.proname::text"
    SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"p.prosrc" -- text
    SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlResult v) =>
SQL -> m ()
sqlResult SQL
"c.relname::text"
    SQL -> SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlFrom v) =>
SQL -> SQL -> m ()
sqlJoinOn SQL
"pg_proc p" SQL
"t.tgfoid = p.oid"
    SQL -> SQL -> State SqlSelect ()
forall v (m :: * -> *).
(MonadState v m, SqlFrom v) =>
SQL -> SQL -> m ()
sqlJoinOn SQL
"pg_class c" SQL
"c.oid = t.tgrelid"
    SQL -> Bool -> State SqlSelect ()
forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"t.tgisinternal" Bool
False
    SQL -> Text -> State SqlSelect ()
forall v (m :: * -> *) a.
(MonadState v m, SqlWhere v, Show a, ToSQL a) =>
SQL -> a -> m ()
sqlWhereEq SQL
"c.relname" (Text -> State SqlSelect ()) -> Text -> State SqlSelect ()
forall a b. (a -> b) -> a -> b
$ RawSQL () -> Text
unRawSQL RawSQL ()
tableName
  ((String, Int16, Bool, Bool, Bool, String, String, String, String)
 -> (Trigger, RawSQL ()))
-> m [(Trigger, RawSQL ())]
forall (m :: * -> *) row t.
(HasCallStack, MonadDB m, FromRow row) =>
(row -> t) -> m [t]
fetchMany (String, Int16, Bool, Bool, Bool, String, String, String, String)
-> (Trigger, RawSQL ())
getTrigger
  where
    getTrigger :: (String, Int16, Bool, Bool, Bool, String, String, String, String) -> (Trigger, RawSQL ())
    getTrigger :: (String, Int16, Bool, Bool, Bool, String, String, String, String)
-> (Trigger, RawSQL ())
getTrigger (String
tgname, Int16
tgtype, Bool
tgconstraint, Bool
tgdeferrable, Bool
tginitdeferrable, String
triggerdef, String
proname, String
prosrc, String
tblName) =
      ( Trigger
          { triggerTable :: RawSQL ()
triggerTable = RawSQL ()
tableName'
          , triggerName :: RawSQL ()
triggerName = RawSQL () -> RawSQL () -> RawSQL ()
triggerBaseName (String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL String
tgname) RawSQL ()
tableName'
          , triggerKind :: TriggerKind
triggerKind = TriggerKind
tgrKind
          , triggerEvents :: Set TriggerEvent
triggerEvents = Set TriggerEvent
trgEvents
          , triggerWhen :: Maybe (RawSQL ())
triggerWhen = Maybe (RawSQL ())
tgrWhen
          , triggerFunction :: RawSQL ()
triggerFunction = String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL String
prosrc
          }
      , String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL String
proname
      )
      where
        tableName' :: RawSQL ()
        tableName' :: RawSQL ()
tableName' = String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL String
tblName

        parseBetween :: Text -> Text -> Maybe (RawSQL ())
        parseBetween :: Text -> Text -> Maybe (RawSQL ())
parseBetween Text
left Text
right =
          let (Text
prefix, Text
match) = HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
Text.breakOnEnd Text
left (Text -> (Text, Text)) -> Text -> (Text, Text)
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack String
triggerdef
          in if Text -> Bool
Text.null Text
prefix
              then Maybe (RawSQL ())
forall a. Maybe a
Nothing
              else RawSQL () -> Maybe (RawSQL ())
forall a. a -> Maybe a
Just (RawSQL () -> Maybe (RawSQL ())) -> RawSQL () -> Maybe (RawSQL ())
forall a b. (a -> b) -> a -> b
$ (Text -> () -> RawSQL ()
forall row. (Show row, ToRow row) => Text -> row -> RawSQL row
rawSQL (Text -> () -> RawSQL ())
-> ((Text, Text) -> Text) -> (Text, Text) -> () -> RawSQL ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Text) -> Text
forall a b. (a, b) -> a
fst ((Text, Text) -> () -> RawSQL ())
-> (Text, Text) -> () -> RawSQL ()
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
Text.breakOn Text
right Text
match) ()

        -- Get the WHEN part of the query. Anything between WHEN and EXECUTE is what we
        -- want. The Postgres' grammar guarantees that WHEN and EXECUTE are always next to
        -- each other and in that order.
        tgrWhen :: Maybe (RawSQL ())
        tgrWhen :: Maybe (RawSQL ())
tgrWhen = Text -> Text -> Maybe (RawSQL ())
parseBetween Text
"WHEN (" Text
") EXECUTE"

        tgrKind :: TriggerKind
        tgrKind :: TriggerKind
tgrKind =
          if Bool
tgconstraint
            then ConstraintAttributes -> TriggerKind
TriggerConstraint ConstraintAttributes
trgConstraintAttrs
            else TriggerActionTime -> TriggerKind
TriggerRegular TriggerActionTime
tgrActionTime

        trgConstraintAttrs :: ConstraintAttributes
        trgConstraintAttrs :: ConstraintAttributes
trgConstraintAttrs = case (Bool
tgdeferrable, Bool
tginitdeferrable) of
          (Bool
False, Bool
False) -> ConstraintAttributes
NotDeferrable
          (Bool
True, Bool
False) -> ConstraintAttributes
Deferrable
          (Bool
True, Bool
True) -> ConstraintAttributes
DeferrableInitiallyDeferred
          (Bool
False, Bool
True) -> String -> ConstraintAttributes
forall a. HasCallStack => String -> a
error String
"A constraint declared INITIALLY DEFERRED must be DEFERRABLE."

        tgrActionTime :: TriggerActionTime
        tgrActionTime :: TriggerActionTime
tgrActionTime = case (Bool
tgtypeInsteadBit, Bool
tgtypeBeforeBit) of
          (Bool
False, Bool
False) -> TriggerActionTime
After
          (Bool
False, Bool
True) -> TriggerActionTime
Before
          (Bool
True, Bool
False) -> String -> TriggerActionTime
forall a. HasCallStack => String -> a
error String
"INSTEAD OF triggers are not available on tables."
          (Bool
True, Bool
True) -> String -> TriggerActionTime
forall a. HasCallStack => String -> a
error String
"The tgtype can't match more than one timing."
          where
            -- Taken from PostgreSQL sources: src/include/catalog/pg_trigger.h:
            tgtypeBeforeBit :: Bool
tgtypeBeforeBit = Int16 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Int16
tgtype Int
1 -- #define TRIGGER_TYPE_BEFORE (1 << 1)
            tgtypeInsteadBit :: Bool
tgtypeInsteadBit = Int16 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Int16
tgtype Int
6 -- #define TRIGGER_TYPE_INSTEAD (1 << 6)

        -- Similarly, in case of UPDATE OF, the columns can be simply parsed from the
        -- original query. Note that UPDATE and UPDATE OF are mutually exclusive and have
        -- the same bit set in the underlying tgtype bit field.
        trgEvents :: Set TriggerEvent
        trgEvents :: Set TriggerEvent
trgEvents =
          (Set TriggerEvent -> (Int, TriggerEvent) -> Set TriggerEvent)
-> Set TriggerEvent -> [(Int, TriggerEvent)] -> Set TriggerEvent
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
            ( \Set TriggerEvent
set (Int
mask, TriggerEvent
event) ->
                if Int16 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Int16
tgtype Int
mask
                  then
                    TriggerEvent -> Set TriggerEvent -> Set TriggerEvent
forall a. Ord a => a -> Set a -> Set a
Set.insert
                      ( if TriggerEvent
event TriggerEvent -> TriggerEvent -> Bool
forall a. Eq a => a -> a -> Bool
== TriggerEvent
TriggerUpdate
                          then TriggerEvent
-> (RawSQL () -> TriggerEvent) -> Maybe (RawSQL ()) -> TriggerEvent
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TriggerEvent
event RawSQL () -> TriggerEvent
trgUpdateOf (Maybe (RawSQL ()) -> TriggerEvent)
-> Maybe (RawSQL ()) -> TriggerEvent
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Maybe (RawSQL ())
parseBetween Text
"UPDATE OF " Text
" ON"
                          else TriggerEvent
event
                      )
                      Set TriggerEvent
set
                  else Set TriggerEvent
set
            )
            Set TriggerEvent
forall a. Set a
Set.empty
            -- Taken from PostgreSQL sources: src/include/catalog/pg_trigger.h:
            [ (Int
2, TriggerEvent
TriggerInsert) -- #define TRIGGER_TYPE_INSERT (1 << 2)
            , (Int
3, TriggerEvent
TriggerDelete) -- #define TRIGGER_TYPE_DELETE (1 << 3)
            , (Int
4, TriggerEvent
TriggerUpdate) -- #define TRIGGER_TYPE_UPDATE (1 << 4)
            ]

        trgUpdateOf :: RawSQL () -> TriggerEvent
        trgUpdateOf :: RawSQL () -> TriggerEvent
trgUpdateOf RawSQL ()
columnsSQL =
          let columns :: [RawSQL ()]
columns = (Text -> RawSQL ()) -> [Text] -> [RawSQL ()]
forall a b. (a -> b) -> [a] -> [b]
map (String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL (String -> RawSQL ()) -> (Text -> String) -> Text -> RawSQL ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack) ([Text] -> [RawSQL ()]) -> (Text -> [Text]) -> Text -> [RawSQL ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
Text.splitOn Text
", " (Text -> [RawSQL ()]) -> Text -> [RawSQL ()]
forall a b. (a -> b) -> a -> b
$ RawSQL () -> Text
unRawSQL RawSQL ()
columnsSQL
          in [RawSQL ()] -> TriggerEvent
TriggerUpdateOf [RawSQL ()]
columns

-- | Build an SQL statement for creating a trigger function.
--
-- Since we only support @CONSTRAINT@ triggers, the function will always @RETURN TRIGGER@
-- and will have no parameters.
--
-- @since 1.15.0.0
sqlCreateTriggerFunction :: Trigger -> RawSQL ()
sqlCreateTriggerFunction :: Trigger -> RawSQL ()
sqlCreateTriggerFunction Trigger {Maybe (RawSQL ())
Set TriggerEvent
RawSQL ()
TriggerKind
triggerTable :: Trigger -> RawSQL ()
triggerName :: Trigger -> RawSQL ()
triggerKind :: Trigger -> TriggerKind
triggerEvents :: Trigger -> Set TriggerEvent
triggerWhen :: Trigger -> Maybe (RawSQL ())
triggerFunction :: Trigger -> RawSQL ()
triggerTable :: RawSQL ()
triggerName :: RawSQL ()
triggerKind :: TriggerKind
triggerEvents :: Set TriggerEvent
triggerWhen :: Maybe (RawSQL ())
triggerFunction :: RawSQL ()
..} =
  RawSQL ()
"CREATE FUNCTION"
    RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL () -> RawSQL ()
triggerFunctionMakeName RawSQL ()
triggerName
    RawSQL () -> RawSQL () -> RawSQL ()
forall a. Semigroup a => a -> a -> a
<> RawSQL ()
"()"
    RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
"RETURNS TRIGGER"
    RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
"AS $$"
    RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
triggerFunction
    RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
"$$"
    RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
"LANGUAGE PLPGSQL"
    RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
"VOLATILE"
    RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
"RETURNS NULL ON NULL INPUT"

-- | Build an SQL statement for dropping a trigger function.
--
-- @since 1.15.0.0
sqlDropTriggerFunction :: Trigger -> RawSQL ()
sqlDropTriggerFunction :: Trigger -> RawSQL ()
sqlDropTriggerFunction Trigger {Maybe (RawSQL ())
Set TriggerEvent
RawSQL ()
TriggerKind
triggerTable :: Trigger -> RawSQL ()
triggerName :: Trigger -> RawSQL ()
triggerKind :: Trigger -> TriggerKind
triggerEvents :: Trigger -> Set TriggerEvent
triggerWhen :: Trigger -> Maybe (RawSQL ())
triggerFunction :: Trigger -> RawSQL ()
triggerTable :: RawSQL ()
triggerName :: RawSQL ()
triggerKind :: TriggerKind
triggerEvents :: Set TriggerEvent
triggerWhen :: Maybe (RawSQL ())
triggerFunction :: RawSQL ()
..} =
  RawSQL ()
"DROP FUNCTION" RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL () -> RawSQL ()
triggerFunctionMakeName RawSQL ()
triggerName RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
"RESTRICT"

-- | Make a trigger function name that can be used in SQL.
--
-- Given a base @name@, return a new name that will be used as the actual name
-- of the trigger function in an SQL query. The returned name is in the format
-- @trgfun\__\<name\>@.
--
-- @since 1.16.0.0
triggerFunctionMakeName :: RawSQL () -> RawSQL ()
triggerFunctionMakeName :: RawSQL () -> RawSQL ()
triggerFunctionMakeName RawSQL ()
name = RawSQL ()
"trgfun__" RawSQL () -> RawSQL () -> RawSQL ()
forall a. Semigroup a => a -> a -> a
<> RawSQL ()
name