-- |
-- Module: Database.PostgreSQL.PQTypes.Model.Trigger
--
-- Trigger name must be unique among triggers of same table. Only @CONSTRAINT@ triggers are
-- supported. They can only be run @AFTER@ an event. The associated functions are always
-- created with no arguments and always @RETURN TRIGGER@.
--
-- For details, see <https://www.postgresql.org/docs/11/sql-createtrigger.html>.

module Database.PostgreSQL.PQTypes.Model.Trigger (
  -- * Trigger functions
    TriggerFunction(..)
  , sqlCreateTriggerFunction
  , sqlDropTriggerFunction
  -- * Triggers
  , TriggerEvent(..)
  , Trigger(..)
  , triggerMakeName
  , triggerBaseName
  , sqlCreateTrigger
  , sqlDropTrigger
  , createTrigger
  , dropTrigger
  , getDBTriggers
  ) where

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

-- | Function associated with a trigger.
--
-- @since 1.15.0.0
data TriggerFunction = TriggerFunction {
    TriggerFunction -> RawSQL ()
tfName   :: RawSQL ()
    -- ^ The function's name.
  , TriggerFunction -> RawSQL ()
tfSource :: RawSQL ()
    -- ^ The functions's body source code.
} deriving (Int -> TriggerFunction -> ShowS
[TriggerFunction] -> ShowS
TriggerFunction -> String
(Int -> TriggerFunction -> ShowS)
-> (TriggerFunction -> String)
-> ([TriggerFunction] -> ShowS)
-> Show TriggerFunction
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TriggerFunction] -> ShowS
$cshowList :: [TriggerFunction] -> ShowS
show :: TriggerFunction -> String
$cshow :: TriggerFunction -> String
showsPrec :: Int -> TriggerFunction -> ShowS
$cshowsPrec :: Int -> TriggerFunction -> ShowS
Show)

instance Eq TriggerFunction where
  -- Since the functions have no arguments, it's impossible to create two functions with
  -- the same name. Therefore comparing functions only by their names is enough in this
  -- case. The assumption is, of course, that the database schema is only changed using
  -- this framework.
  TriggerFunction
f1 == :: TriggerFunction -> TriggerFunction -> Bool
== TriggerFunction
f2 = TriggerFunction -> RawSQL ()
tfName TriggerFunction
f1 RawSQL () -> RawSQL () -> Bool
forall a. Eq a => a -> a -> Bool
== TriggerFunction -> RawSQL ()
tfName TriggerFunction
f2

-- | 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 :: TriggerFunction -> RawSQL ()
sqlCreateTriggerFunction :: TriggerFunction -> RawSQL ()
sqlCreateTriggerFunction TriggerFunction{RawSQL ()
tfSource :: RawSQL ()
tfName :: RawSQL ()
tfSource :: TriggerFunction -> RawSQL ()
tfName :: TriggerFunction -> RawSQL ()
..} =
  RawSQL ()
"CREATE FUNCTION"
    RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
tfName
    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 ()
tfSource
    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 :: TriggerFunction -> RawSQL ()
sqlDropTriggerFunction :: TriggerFunction -> RawSQL ()
sqlDropTriggerFunction TriggerFunction{RawSQL ()
tfSource :: RawSQL ()
tfName :: RawSQL ()
tfSource :: TriggerFunction -> RawSQL ()
tfName :: TriggerFunction -> RawSQL ()
..} =
  RawSQL ()
"DROP FUNCTION" RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
tfName RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
"RESTRICT"

-- | Trigger event name.
--
-- @since 1.15.0.0
data TriggerEvent
  = TriggerInsert
  -- ^ The @INSERT@ event.
  | TriggerUpdate
  -- ^ The @UPDATE@ event.
  | TriggerUpdateOf [RawSQL ()]
  -- ^ The @UPDATE OF column1 [, column2 ...]@ event.
  | TriggerDelete
  -- ^ The @DELETE@ event.
  deriving (TriggerEvent -> TriggerEvent -> Bool
(TriggerEvent -> TriggerEvent -> Bool)
-> (TriggerEvent -> TriggerEvent -> Bool) -> Eq TriggerEvent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TriggerEvent -> TriggerEvent -> Bool
$c/= :: TriggerEvent -> TriggerEvent -> Bool
== :: TriggerEvent -> TriggerEvent -> Bool
$c== :: 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
min :: TriggerEvent -> TriggerEvent -> TriggerEvent
$cmin :: TriggerEvent -> TriggerEvent -> TriggerEvent
max :: TriggerEvent -> TriggerEvent -> TriggerEvent
$cmax :: TriggerEvent -> TriggerEvent -> TriggerEvent
>= :: TriggerEvent -> TriggerEvent -> Bool
$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
compare :: TriggerEvent -> TriggerEvent -> Ordering
$ccompare :: TriggerEvent -> TriggerEvent -> Ordering
$cp1Ord :: Eq 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
showList :: [TriggerEvent] -> ShowS
$cshowList :: [TriggerEvent] -> ShowS
show :: TriggerEvent -> String
$cshow :: TriggerEvent -> String
showsPrec :: Int -> TriggerEvent -> ShowS
$cshowsPrec :: Int -> 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 -> 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 -> Bool
triggerDeferrable        :: Bool
    -- ^ Is the trigger @DEFERRABLE@ or @NOT DEFERRABLE@ ?
  , Trigger -> Bool
triggerInitiallyDeferred :: Bool
    -- ^ Is the trigger @INITIALLY DEFERRED@ or @INITIALLY IMMEDIATE@ ?
  , 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 -> TriggerFunction
triggerFunction          :: TriggerFunction
    -- ^ The function to execute when the trigger fires.
} deriving (Trigger -> Trigger -> Bool
(Trigger -> Trigger -> Bool)
-> (Trigger -> Trigger -> Bool) -> Eq Trigger
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Trigger -> Trigger -> Bool
$c/= :: Trigger -> Trigger -> Bool
== :: Trigger -> Trigger -> Bool
$c== :: Trigger -> Trigger -> Bool
Eq, 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
showList :: [Trigger] -> ShowS
$cshowList :: [Trigger] -> ShowS
show :: Trigger -> String
$cshow :: Trigger -> String
showsPrec :: Int -> Trigger -> ShowS
$cshowsPrec :: Int -> Trigger -> ShowS
Show)

-- | 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
. 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 (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.
--
-- Only supports @CONSTRAINT@ triggers which can only run @AFTER@.
--
-- @since 1.15.0
sqlCreateTrigger :: Trigger -> RawSQL ()
sqlCreateTrigger :: Trigger -> RawSQL ()
sqlCreateTrigger Trigger{Bool
Maybe (RawSQL ())
Set TriggerEvent
RawSQL ()
TriggerFunction
triggerFunction :: TriggerFunction
triggerWhen :: Maybe (RawSQL ())
triggerInitiallyDeferred :: Bool
triggerDeferrable :: Bool
triggerEvents :: Set TriggerEvent
triggerName :: RawSQL ()
triggerTable :: RawSQL ()
triggerFunction :: Trigger -> TriggerFunction
triggerWhen :: Trigger -> Maybe (RawSQL ())
triggerInitiallyDeferred :: Trigger -> Bool
triggerDeferrable :: Trigger -> Bool
triggerEvents :: Trigger -> Set TriggerEvent
triggerName :: Trigger -> RawSQL ()
triggerTable :: Trigger -> RawSQL ()
..} =
  RawSQL ()
"CREATE CONSTRAINT 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 ()
"AFTER" 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 ()
trgTiming
    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
    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
    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
    trgTiming :: RawSQL ()
trgTiming = let deferrable :: RawSQL ()
deferrable = (if Bool
triggerDeferrable then RawSQL ()
"" else RawSQL ()
"NOT") RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
"DEFERRABLE"
                    deferred :: RawSQL ()
deferred   = if Bool
triggerInitiallyDeferred
                                 then RawSQL ()
"INITIALLY DEFERRED"
                                 else RawSQL ()
"INITIALLY IMMEDIATE"
                in RawSQL ()
deferrable RawSQL () -> RawSQL () -> RawSQL ()
forall m. (IsString m, Monoid m) => m -> m -> m
<+> RawSQL ()
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 = TriggerFunction -> RawSQL ()
tfName TriggerFunction
triggerFunction


-- | Build an SQL statement that drops a trigger.
--
-- @since 1.15.0
sqlDropTrigger :: Trigger -> RawSQL ()
sqlDropTrigger :: Trigger -> RawSQL ()
sqlDropTrigger Trigger{Bool
Maybe (RawSQL ())
Set TriggerEvent
RawSQL ()
TriggerFunction
triggerFunction :: TriggerFunction
triggerWhen :: Maybe (RawSQL ())
triggerInitiallyDeferred :: Bool
triggerDeferrable :: Bool
triggerEvents :: Set TriggerEvent
triggerName :: RawSQL ()
triggerTable :: RawSQL ()
triggerFunction :: Trigger -> TriggerFunction
triggerWhen :: Trigger -> Maybe (RawSQL ())
triggerInitiallyDeferred :: Trigger -> Bool
triggerDeferrable :: Trigger -> Bool
triggerEvents :: Trigger -> Set TriggerEvent
triggerName :: Trigger -> RawSQL ()
triggerTable :: Trigger -> 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 :: Trigger -> m ()
createTrigger Trigger
trigger = do
  -- TODO: Use 'withTransaction' here? That would mean adding MonadMask...
  RawSQL () -> m ()
forall sql (m :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ (RawSQL () -> m ())
-> (TriggerFunction -> RawSQL ()) -> TriggerFunction -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TriggerFunction -> RawSQL ()
sqlCreateTriggerFunction (TriggerFunction -> m ()) -> TriggerFunction -> m ()
forall a b. (a -> b) -> a -> b
$ Trigger -> TriggerFunction
triggerFunction Trigger
trigger
  RawSQL () -> m ()
forall sql (m :: * -> *). (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 :: 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 :: * -> *). (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 :: * -> *). (IsSQL sql, MonadDB m) => sql -> m ()
runQuery_ (RawSQL () -> m ())
-> (TriggerFunction -> RawSQL ()) -> TriggerFunction -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TriggerFunction -> RawSQL ()
sqlDropTriggerFunction (TriggerFunction -> m ()) -> TriggerFunction -> m ()
forall a b. (a -> b) -> a -> b
$ Trigger -> TriggerFunction
triggerFunction 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@.
--
-- 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]
getDBTriggers :: RawSQL () -> m [Trigger]
getDBTriggers RawSQL ()
tableName = do
  SqlSelect -> m ()
forall sql (m :: * -> *). (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.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" -- name
    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, String, String, String, String)
 -> Trigger)
-> m [Trigger]
forall (m :: * -> *) row t.
(MonadDB m, FromRow row) =>
(row -> t) -> m [t]
fetchMany (String, Int16, Bool, Bool, String, String, String, String)
-> Trigger
getTrigger
  where
    getTrigger :: (String, Int16, Bool, Bool, String, String, String, String) -> Trigger
    getTrigger :: (String, Int16, Bool, Bool, String, String, String, String)
-> Trigger
getTrigger (String
tgname, Int16
tgtype, Bool
tgdeferrable, Bool
tginitdeferrable, String
triggerdef, String
proname, String
prosrc, String
tblName) =
      Trigger :: RawSQL ()
-> RawSQL ()
-> Set TriggerEvent
-> Bool
-> Bool
-> Maybe (RawSQL ())
-> TriggerFunction
-> Trigger
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'
              , triggerEvents :: Set TriggerEvent
triggerEvents = Set TriggerEvent
trgEvents
              , triggerDeferrable :: Bool
triggerDeferrable = Bool
tgdeferrable
              , triggerInitiallyDeferred :: Bool
triggerInitiallyDeferred = Bool
tginitdeferrable
              , triggerWhen :: Maybe (RawSQL ())
triggerWhen = Maybe (RawSQL ())
tgrWhen
              , triggerFunction :: TriggerFunction
triggerFunction = RawSQL () -> RawSQL () -> TriggerFunction
TriggerFunction (String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL String
proname) (String -> RawSQL ()
forall sql. (IsSQL sql, IsString sql) => String -> sql
unsafeSQL String
prosrc)
              }
      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) = 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
$ 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"

        -- 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 (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
. 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