Address more concerns

* Use unsafeSQL instead of fromString
* Update TODO with issue link
* Add dropTrigger
* CreateTriggerMigration Trigger should not exit. It should be just a function that can be
  added to any StandardMigration
* Rewrite tests using createTrigger and StandardMigration and add more tests for
  dropTrigger as well

src/Database/PostgreSQL/PQTypes/Checks.hs

@@ -614,16 +614,13 @@ checkDBConsistency options domains tablesWithVersions migrations = do
 
     validateMigrations :: m ()
     validateMigrations = forM_ tables $ \table -> do
+      -- FIXME: https://github.com/scrive/hpqtypes-extras/issues/73
       let presentMigrationVersions
             = [ mgrFrom | Migration{..} <- migrations
                         , mgrTableName == tblName table ]
           expectedMigrationVersions
             = reverse $ take (length presentMigrationVersions) $
               reverse  [0 .. tblVersion table - 1]
-            -- -- TODO: File a separate issue about this with a reproducer!
-            -- = if null presentMigrationVersions
-            --   then []
-            --   else [0 .. tblVersion table - 1]
 
       checkMigrationsListValidity table presentMigrationVersions
         expectedMigrationVersions
@@ -833,13 +830,6 @@ checkDBConsistency options domains tablesWithVersions migrations = do
           runQuery_ (sqlDropIndexConcurrently tname idx) `finally` begin
           updateTableVersion
 
-        CreateTriggerMigration trigger@Trigger{..} -> do
-          logInfo_ $ "  Creating function" <+> (unRawSQL $ tfName triggerFunction)
-          runQuery_ $ sqlCreateTriggerFunction triggerFunction
-          logInfo_ $ "  Creating trigger" <+> (unRawSQL $ triggerMakeName triggerName triggerTable)
-          runQuery_ $ sqlCreateTrigger trigger
-          updateTableVersion
-
       where
         logMigration = do
           logInfo_ $ arrListTable mgrTableName

src/Database/PostgreSQL/PQTypes/Migrate.hs

@@ -47,6 +47,4 @@ createTableConstraints Table{..} = when (not $ null addConstraints) $ do
       ]
 
 createTableTriggers :: MonadDB m => Table -> m ()
-createTableTriggers Table{..} = forM_ tblTriggers $ \t -> do
-  runQuery_ . sqlCreateTriggerFunction $ triggerFunction t
-  runQuery_ $ sqlCreateTrigger t
+createTableTriggers Table{..} = forM_ tblTriggers createTrigger

src/Database/PostgreSQL/PQTypes/Model/Migration.hs

@@ -33,7 +33,6 @@ import Data.Int
 
 import Database.PostgreSQL.PQTypes.Model.Index
 import Database.PostgreSQL.PQTypes.Model.Table
-import Database.PostgreSQL.PQTypes.Model.Trigger
 import Database.PostgreSQL.PQTypes.SQL.Raw
 
 -- | Migration action to run, either an arbitrary 'MonadDB' action, or
@@ -58,9 +57,6 @@ data MigrationAction m =
       (RawSQL ()) -- ^ Table name
       TableIndex  -- ^ Index
 
-  -- | Migration for creating a trigger.
-  | CreateTriggerMigration Trigger
-
 -- | Migration object.
 data Migration m =
   Migration {
@@ -82,7 +78,6 @@ isStandardMigration Migration{..} =
     DropTableMigration{}               -> False
     CreateIndexConcurrentlyMigration{} -> False
     DropIndexConcurrentlyMigration{}   -> False
-    CreateTriggerMigration{}           -> False
 
 isDropTableMigration :: Migration m -> Bool
 isDropTableMigration Migration{..} =
@@ -91,4 +86,3 @@ isDropTableMigration Migration{..} =
     DropTableMigration{}               -> True
     CreateIndexConcurrentlyMigration{} -> False
     DropIndexConcurrentlyMigration{}   -> False
-    CreateTriggerMigration{}           -> False

src/Database/PostgreSQL/PQTypes/Model/Trigger.hs

@@ -11,12 +11,16 @@ module Database.PostgreSQL.PQTypes.Model.Trigger (
   -- * Trigger functions
     TriggerFunction(..)
   , sqlCreateTriggerFunction
+  , sqlDropTriggerFunction
   -- * Triggers
   , TriggerEvent(..)
   , Trigger(..)
   , triggerMakeName
   , triggerBaseName
   , sqlCreateTrigger
+  , sqlDropTrigger
+  , createTrigger
+  , dropTrigger
   , getDBTriggers
   ) where
 
@@ -54,16 +58,23 @@ instance Eq TriggerFunction where
 -- @since 1.15.0.0
 sqlCreateTriggerFunction :: TriggerFunction -> RawSQL ()
 sqlCreateTriggerFunction TriggerFunction{..} =
-      "CREATE FUNCTION"
-      <+> tfName
-      <>  "()"
-      <+> "RETURNS TRIGGER"
-      <+> "AS $$"
-      <+> tfSource
-      <+> "$$"
-      <+> "LANGUAGE PLPGSQL"
-      <+> "VOLATILE"
-      <+> "RETURNS NULL ON NULL INPUT"
+  "CREATE FUNCTION"
+    <+> tfName
+    <>  "()"
+    <+> "RETURNS TRIGGER"
+    <+> "AS $$"
+    <+> tfSource
+    <+> "$$"
+    <+> "LANGUAGE PLPGSQL"
+    <+> "VOLATILE"
+    <+> "RETURNS NULL ON NULL INPUT"
+
+-- | Build an SQL statement for dropping a trigger function.
+--
+-- @since 1.15.0.0
+sqlDropTriggerFunction :: TriggerFunction -> RawSQL ()
+sqlDropTriggerFunction TriggerFunction{..} =
+  "DROP FUNCTION" <+> tfName <+> "RESTRICT"
 
 -- | Trigger event name.
 --
@@ -141,7 +152,7 @@ sqlCreateTrigger Trigger{..} =
     <+> "FOR EACH ROW"
     <+> trgWhen
     <+> "EXECUTE FUNCTION" <+> trgFunction
-    <+> "();"
+    <+> "()"
   where
     trgName
       | triggerName == "" = error "Trigger must have a name."
@@ -157,6 +168,43 @@ sqlCreateTrigger Trigger{..} =
     trgWhen = maybe "" (\w -> "WHEN (" <+> w <+> ")") triggerWhen
     trgFunction = tfName triggerFunction
 
+
+-- | Build an SQL statement that drops a trigger.
+--
+-- @since 1.15.0
+sqlDropTrigger :: Trigger -> RawSQL ()
+sqlDropTrigger Trigger{..} =
+  -- 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.
+  "DROP TRIGGER" <+> trgName <+> "ON" <+> triggerTable <+> "RESTRICT"
+  where
+    trgName
+      | triggerName == "" = error "Trigger must have a name."
+      | otherwise = triggerMakeName triggerName 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 = do
+  -- TODO: Use 'withTransaction' here? That would mean adding MonadMask...
+  runQuery_ . sqlCreateTriggerFunction $ triggerFunction trigger
+  runQuery_ $ sqlCreateTrigger trigger
+
+-- | Drop the trigger from the database.
+--
+-- @since 1.15.0
+dropTrigger :: MonadDB m => Trigger -> m ()
+dropTrigger 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...
+  runQuery_ $ sqlDropTrigger trigger
+  runQuery_ . sqlDropTriggerFunction $ triggerFunction trigger
+
 -- | Get all noninternal triggers from the database.
 --
 -- Run a query that returns all triggers associated with the given table and marked as

test/Main.hs

@@ -1038,6 +1038,51 @@ testTriggers step = do
     triggerStep msg $ do
       assertDBException msg $ migrate ts ms
 
+  do
+    let msg = "database exception is raised if dropping trigger that does not exist"
+        trg = bankTrigger1
+        ts = [ tableBankSchema1 { tblVersion = 2
+                                , tblTriggers = [trg]
+                                }
+             ]
+        ms = [ dropTriggerMigration 1 trg ]
+    triggerStep msg $ do
+      assertDBException msg $ migrate ts ms
+
+  do
+    let msg = "database exception is raised if dropping trigger function of which does not exist"
+        trg = bankTrigger2
+        ts = [ tableBankSchema1 { tblVersion = 2
+                                , tblTriggers = [trg]
+                                }
+             ]
+        ms = [ dropTriggerMigration 1 trg ]
+    triggerStep msg $ do
+      assertDBException msg $ migrate ts ms
+
+  do
+    let msg = "successfully drop trigger"
+        trg = bankTrigger1
+        ts = [ tableBankSchema1 { tblVersion = 3
+                                , tblTriggers = []
+                                }
+             ]
+        ms = [ createTriggerMigration 1 trg, dropTriggerMigration 2 trg ]
+    triggerStep msg $ do
+      migrate ts ms
+      verify []
+
+  do
+    let msg = "database exception is raised if dropping trigger twice"
+        trg = bankTrigger2
+        ts = [ tableBankSchema1 { tblVersion = 3
+                                , tblTriggers = [trg]
+                                }
+             ]
+        ms = [ dropTriggerMigration 1 trg, dropTriggerMigration 2 trg ]
+    triggerStep msg $ do
+      assertDBException msg $ migrate ts ms
+
   where
     triggerStep msg rest = do
       recreateTriggerDB
@@ -1055,13 +1100,19 @@ testTriggers step = do
       let ok = and $ map (`elem` dbTriggers) triggers
       liftIO $ assertBool "Triggers not present in the database." ok
 
-    createTriggerMigration :: MonadDB m => Int -> Trigger -> Migration m
-    createTriggerMigration from trg = Migration
+    triggerMigration :: MonadDB m => (Trigger -> m ()) -> Int -> Trigger -> Migration m
+    triggerMigration fn from trg = Migration
       { mgrTableName = tblName tableBankSchema1
       , mgrFrom = fromIntegral from
-      , mgrAction = CreateTriggerMigration trg
+      , mgrAction = StandardMigration $ fn trg
       }
 
+    createTriggerMigration :: MonadDB m => Int -> Trigger -> Migration m
+    createTriggerMigration = triggerMigration createTrigger
+
+    dropTriggerMigration :: MonadDB m => Int -> Trigger -> Migration m
+    dropTriggerMigration = triggerMigration dropTrigger
+
     recreateTriggerDB = do
       runSQL_ "DROP TRIGGER IF EXISTS trg__bank__trigger_1 ON bank;"
       runSQL_ "DROP TRIGGER IF EXISTS trg__bank__trigger_2 ON bank;"