hpqtypes-extras 1.14.1.0 → 1.15.0.0

raw patch · 20 files changed

+765/−102 lines, 20 filesdep −QuickCheckdep −fields-jsondep −lifted-basedep ~basedep ~containersPVP ok

version bump matches the API change (PVP)

Dependencies removed: QuickCheck, fields-json, lifted-base, monad-control, safe, semigroups, time, transformers, transformers-base

Dependency ranges changed: base, containers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• hpqtypes-extras.cabal +25/−26
• src/Database/PostgreSQL/PQTypes/Checks.hs +19/−8
• src/Database/PostgreSQL/PQTypes/Checks/Util.hs +8/−6
• src/Database/PostgreSQL/PQTypes/Migrate.hs +7/−1
• src/Database/PostgreSQL/PQTypes/Model.hs +2/−0
• src/Database/PostgreSQL/PQTypes/Model/Check.hs +0/−1
• src/Database/PostgreSQL/PQTypes/Model/ColumnType.hs +0/−3
• src/Database/PostgreSQL/PQTypes/Model/Domain.hs +0/−1
• src/Database/PostgreSQL/PQTypes/Model/Extension.hs +0/−1
• src/Database/PostgreSQL/PQTypes/Model/ForeignKey.hs +0/−2
• src/Database/PostgreSQL/PQTypes/Model/Index.hs +47/−12
• src/Database/PostgreSQL/PQTypes/Model/Migration.hs +0/−10
• src/Database/PostgreSQL/PQTypes/Model/PrimaryKey.hs +0/−2
• src/Database/PostgreSQL/PQTypes/Model/Table.hs +3/−1
• src/Database/PostgreSQL/PQTypes/Model/Trigger.hs +302/−0
• src/Database/PostgreSQL/PQTypes/SQL/Builder.hs +0/−7
• src/Database/PostgreSQL/PQTypes/Utils/NubList.hs +0/−2
• src/Database/PostgreSQL/PQTypes/Versions.hs +0/−2
• test/Main.hs +346/−17

@@ -1,3 +1,9 @@+# hpqtypes-extras-1.15.0.0 (2022-05-11)+* Add support for GHC 9.2.+* Drop support for GHC < 8.8.+* Add support for triggers and trigger functions.+* Allow to specify the operator class of an index column.+ # hpqtypes-extras-1.14.1.0 (2022-01-11) * Support unmanaged local indexes whose names start with "local_". 

@@ -1,6 +1,6 @@ cabal-version:       2.2 name:                hpqtypes-extras-version:             1.14.1.0+version:             1.15.0.0 synopsis:            Extra utilities for hpqtypes library description:         The following extras for hpqtypes library:                      .@@ -20,7 +20,7 @@ copyright:           Scrive AB category:            Database build-type:          Simple-tested-with:         GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2+tested-with:         GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.2  Source-repository head   Type:     git@@ -47,7 +47,8 @@                     , ViewPatterns  library-  Import: common-stanza+  import: common-stanza+   hs-source-dirs: src    ghc-options: -Wall@@ -67,12 +68,14 @@                  , Database.PostgreSQL.PQTypes.Model.Migration                  , Database.PostgreSQL.PQTypes.Model.PrimaryKey                  , Database.PostgreSQL.PQTypes.Model.Table+                 , Database.PostgreSQL.PQTypes.Model.Trigger                  , Database.PostgreSQL.PQTypes.SQL.Builder                  , Database.PostgreSQL.PQTypes.Versions+   other-modules:   Database.PostgreSQL.PQTypes.Checks.Util                  , Database.PostgreSQL.PQTypes.Utils.NubList -  build-depends: base              >= 4.9     && < 5+  build-depends: base              >= 4.13     && < 5                , hpqtypes          >= 1.8.0.0                , base16-bytestring >= 0.1                , bytestring        >= 0.10@@ -81,47 +84,43 @@                , exceptions        >= 0.10                , extra             >= 1.6.17                , mtl               >= 2.2-               , fields-json       >= 0.4                , text              >= 1.2-               , lifted-base       >= 0.2-               , monad-control     >= 1.0.3.1-               , semigroups        >= 0.16                , text-show         >= 3.7-               , transformers-base                , log-base          >= 0.11-               , safe              >= 0.3    default-language: Haskell2010   default-extensions:-  other-extensions:   CPP  test-suite  hpqtypes-extras-tests-  Import:             common-stanza+  import:             common-stanza+   type:               exitcode-stdio-1.0+   hs-source-dirs:     test+   main-is:            Main.hs+   default-language:   Haskell2010+   default-extensions: ConstraintKinds                     , DeriveDataTypeable                     , FlexibleContexts                     , OverloadedStrings                     , RecordWildCards                     , ScopedTypeVariables+   ghc-options:        -Wall-  build-depends:      base,-                      QuickCheck,-                      exceptions,-                      hpqtypes,-                      hpqtypes-extras,-                      lifted-base,-                      log-base,-                      monad-control,-                      tasty,-                      tasty-hunit,-                      text,-                      time,-                      transformers,-                      uuid-types++  build-depends:      base+                    , containers+                    , exceptions+                    , hpqtypes+                    , hpqtypes-extras+                    , log-base+                    , tasty+                    , tasty-hunit+                    , text+                    , uuid-types  benchmark bench   Import:             common-stanza

@@ -14,15 +14,13 @@   ) where  import Control.Arrow ((&&&))-import Control.Concurrent.Lifted (threadDelay)-import Control.Monad.Base+import Control.Concurrent (threadDelay) import Control.Monad.Catch import Control.Monad.Reader import Data.Int import Data.Function (on) import Data.List (partition) import Data.Maybe-import Data.Monoid import Data.Monoid.Utils import Data.Ord (comparing) import Data.Typeable (cast)@@ -31,7 +29,6 @@ import Database.PostgreSQL.PQTypes import GHC.Stack (HasCallStack) import Log-import Prelude import TextShow import qualified Data.List as L import qualified Data.Map as M@@ -53,7 +50,7 @@  -- | Run migrations and check the database structure. migrateDatabase-  :: (MonadBase IO m, MonadDB m, MonadLog m, MonadMask m)+  :: (MonadIO m, MonadDB m, MonadLog m, MonadMask m)   => ExtrasOptions   -> [Extension]   -> [CompositeType]@@ -422,12 +419,14 @@       indexes <- fetchMany fetchTableIndex       runQuery_ $ sqlGetForeignKeys table       fkeys <- fetchMany fetchForeignKey+      triggers <- getDBTriggers tblName       return $ mconcat [           checkColumns 1 tblColumns desc         , checkPrimaryKey tblPrimaryKey pk         , checkChecks tblChecks checks         , checkIndexes tblIndexes indexes         , checkForeignKeys tblForeignKeys fkeys+        , checkTriggers tblTriggers triggers         ]       where         fetchTableColumn@@ -544,6 +543,17 @@           , checkNames (fkName tblName) fkeys           ] +        checkTriggers :: [Trigger] -> [Trigger] -> ValidationResult+        checkTriggers defs triggers =+          mapValidationResult id mapErrs $ checkEquality "TRIGGERs" defs triggers+          where+            mapErrs []      = []+            mapErrs errmsgs = errmsgs <>+              [ "(HINT: If WHEN clauses are equal modulo number of parentheses, whitespace, \+                \case of variables or type casts used in conditions, just copy and paste \+                \expected output into source code.)"+              ]+ -- | Checks whether database is consistent, performing migrations if -- necessary. Requires all table names to be in lower case. --@@ -553,7 +563,7 @@ --   * all 'mgrFrom' are less than table version number of the table in --     the 'tables' list checkDBConsistency-  :: forall m. (MonadBase IO m, MonadDB m, MonadLog m, MonadMask m)+  :: forall m. (MonadIO m, MonadDB m, MonadLog m, MonadMask m)   => ExtrasOptions -> [Domain] -> TablesWithVersions -> [Migration m]   -> m () checkDBConsistency options domains tablesWithVersions migrations = do@@ -604,6 +614,7 @@      validateMigrations :: m ()     validateMigrations = forM_ tables $ \table -> do+      -- FIXME: https://github.com/scrive/hpqtypes-extras/issues/73       let presentMigrationVersions             = [ mgrFrom | Migration{..} <- migrations                         , mgrTableName == tblName table ]@@ -837,7 +848,7 @@           let restartMigration query = do                 logAttention "Failed to acquire a lock" $ object ["query" .= query]                 logInfo_ "Restarting the migration shortly..."-                threadDelay 1000000+                liftIO $ threadDelay 1000000                 loop           handleJust lockNotAvailable restartMigration $ do             forM_ (eoLockTimeoutMs options) $ \lockTimeout -> do@@ -1106,7 +1117,7 @@   -> (TableIndex, RawSQL ()) fetchTableIndex (name, Array1 keyColumns, Array1 includeColumns, method, unique, valid, mconstraint) =   (TableIndex-   { idxColumns = map unsafeSQL keyColumns+   { idxColumns = map (indexColumn . unsafeSQL) keyColumns    , idxInclude = map unsafeSQL includeColumns    , idxMethod = read method    , idxUnique = unique

@@ -95,19 +95,21 @@ checkEquality :: (Eq t, Show t) => Text -> [t] -> [t] -> ValidationResult checkEquality pname defs props = case (defs L.\\ props, props L.\\ defs) of   ([], []) -> mempty-  (def_diff, db_diff) -> validationError . mconcat $ [+  (def_diff, db_diff) -> validationError $ mconcat [       "Table and its definition have diverged and have "     , showt $ length db_diff     , " and "     , showt $ length def_diff     , " different "     , pname-    , " each, respectively (table: "-    , T.pack $ show db_diff-    , ", definition: "-    , T.pack $ show def_diff-    , ")."+    , " each, respectively:\n"+    , "  ● table:"+    , showDiff db_diff+    , "\n  ● definition:"+    , showDiff def_diff     ]+  where+    showDiff = mconcat . map (("\n    ○ " <>) . T.pack . show)  checkNames :: Show t => (t -> RawSQL ()) -> [(t, RawSQL ())] -> ValidationResult checkNames prop_name = mconcat . map check

@@ -1,7 +1,8 @@ module Database.PostgreSQL.PQTypes.Migrate (   createDomain,   createTable,-  createTableConstraints+  createTableConstraints,+  createTableTriggers   ) where  import Control.Monad@@ -28,6 +29,8 @@   forM_ tblIndexes $ runQuery_ . sqlCreateIndexMaybeDowntime tblName   -- Add all the other constraints if applicable.   when withConstraints $ createTableConstraints table+  -- Create triggers.+  createTableTriggers table   -- Register the table along with its version.   runQuery_ . sqlInsert "table_versions" $ do     sqlSet "name" (tblNameText table)@@ -42,3 +45,6 @@       , map sqlAddValidCheckMaybeDowntime tblChecks       , map (sqlAddValidFKMaybeDowntime tblName) tblForeignKeys       ]++createTableTriggers :: MonadDB m => Table -> m ()+createTableTriggers = mapM_ createTrigger . tblTriggers

@@ -9,6 +9,7 @@   , module Database.PostgreSQL.PQTypes.Model.Migration   , module Database.PostgreSQL.PQTypes.Model.PrimaryKey   , module Database.PostgreSQL.PQTypes.Model.Table+  , module Database.PostgreSQL.PQTypes.Model.Trigger   ) where  import Database.PostgreSQL.PQTypes.Model.Check@@ -21,3 +22,4 @@ import Database.PostgreSQL.PQTypes.Model.Migration import Database.PostgreSQL.PQTypes.Model.PrimaryKey import Database.PostgreSQL.PQTypes.Model.Table+import Database.PostgreSQL.PQTypes.Model.Trigger

@@ -9,7 +9,6 @@  import Data.Monoid.Utils import Database.PostgreSQL.PQTypes-import Prelude  data Check = Check {   chkName      :: RawSQL ()

@@ -3,10 +3,7 @@   , columnTypeToSQL   ) where -import Control.Applicative ((<$>))-import Data.Monoid import Database.PostgreSQL.PQTypes-import Prelude import qualified Data.Text as T  data ColumnType

@@ -9,7 +9,6 @@ import Data.Monoid.Utils import Data.Set (Set, fromList) import Database.PostgreSQL.PQTypes-import Prelude  import Database.PostgreSQL.PQTypes.Model.Check import Database.PostgreSQL.PQTypes.Model.ColumnType

@@ -6,7 +6,6 @@ import Data.String import Data.Text (Text) import Database.PostgreSQL.PQTypes-import Prelude  newtype Extension = Extension { unExtension :: RawSQL () }   deriving (Eq, Ord, Show, IsString)

@@ -10,10 +10,8 @@   , sqlDropFK   ) where -import Data.Monoid import Data.Monoid.Utils import Database.PostgreSQL.PQTypes-import Prelude import qualified Data.Text as T  data ForeignKey = ForeignKey {

@@ -1,5 +1,8 @@ module Database.PostgreSQL.PQTypes.Model.Index (     TableIndex(..)+  , IndexColumn(..)+  , indexColumn+  , indexColumnWithOperatorClass   , IndexMethod(..)   , tblIndex   , indexOnColumn@@ -19,16 +22,16 @@ import Crypto.Hash.RIPEMD160 import Data.ByteString.Base16 import Data.Char-import Data.Monoid+import Data.Function+import Data.String import Data.Monoid.Utils import Database.PostgreSQL.PQTypes-import Prelude import qualified Data.ByteString.Char8 as BS import qualified Data.Text as T import qualified Data.Text.Encoding as T  data TableIndex = TableIndex {-  idxColumns :: [RawSQL ()]+  idxColumns :: [IndexColumn] , idxInclude :: [RawSQL ()] , idxMethod  :: IndexMethod , idxUnique  :: Bool@@ -38,6 +41,32 @@ , idxWhere   :: Maybe (RawSQL ()) } deriving (Eq, Ord, Show) +data IndexColumn+  = IndexColumn (RawSQL ()) (Maybe (RawSQL ()))+  deriving Show++-- If one of the two columns doesn't specify the operator class, we just ignore+-- it and still treat them as equivalent.+instance Eq IndexColumn where+  IndexColumn x Nothing == IndexColumn y _ = x == y+  IndexColumn x _ == IndexColumn y Nothing = x == y+  IndexColumn x (Just x') == IndexColumn y (Just y') = x == y && x' == y'++instance Ord IndexColumn where+  compare = compare `on` indexColumnName++instance IsString IndexColumn where+  fromString s = IndexColumn (fromString s) Nothing++indexColumn :: RawSQL () -> IndexColumn+indexColumn col = IndexColumn col Nothing++indexColumnWithOperatorClass :: RawSQL () -> RawSQL () -> IndexColumn+indexColumnWithOperatorClass col opclass = IndexColumn col (Just opclass)++indexColumnName :: IndexColumn -> RawSQL ()+indexColumnName (IndexColumn col _) = col+ data IndexMethod =     BTree   | GIN@@ -62,28 +91,28 @@ , idxWhere = Nothing } -indexOnColumn :: RawSQL () -> TableIndex+indexOnColumn :: IndexColumn -> TableIndex indexOnColumn column = tblIndex { idxColumns = [column] }  -- | Create an index on the given column with the specified method.  No checks -- are made that the method is appropriate for the type of the column.-indexOnColumnWithMethod :: RawSQL () -> IndexMethod -> TableIndex+indexOnColumnWithMethod :: IndexColumn -> IndexMethod -> TableIndex indexOnColumnWithMethod column method =     tblIndex { idxColumns = [column]              , idxMethod = method } -indexOnColumns :: [RawSQL ()] -> TableIndex+indexOnColumns :: [IndexColumn] -> TableIndex indexOnColumns columns = tblIndex { idxColumns = columns }  -- | Create an index on the given columns with the specified method.  No checks -- are made that the method is appropriate for the type of the column; -- cf. [the PostgreSQL manual](https://www.postgresql.org/docs/current/static/indexes-multicolumn.html).-indexOnColumnsWithMethod :: [RawSQL ()] -> IndexMethod -> TableIndex+indexOnColumnsWithMethod :: [IndexColumn] -> IndexMethod -> TableIndex indexOnColumnsWithMethod columns method =     tblIndex { idxColumns = columns              , idxMethod = method } -uniqueIndexOnColumn :: RawSQL () -> TableIndex+uniqueIndexOnColumn :: IndexColumn -> TableIndex uniqueIndexOnColumn column = TableIndex {   idxColumns = [column] , idxInclude = []@@ -93,7 +122,7 @@ , idxWhere = Nothing } -uniqueIndexOnColumns :: [RawSQL ()] -> TableIndex+uniqueIndexOnColumns :: [IndexColumn] -> TableIndex uniqueIndexOnColumns columns = TableIndex {   idxColumns = columns , idxInclude = []@@ -103,7 +132,7 @@ , idxWhere = Nothing } -uniqueIndexOnColumnWithCondition :: RawSQL () -> RawSQL () -> TableIndex+uniqueIndexOnColumnWithCondition :: IndexColumn -> RawSQL () -> TableIndex uniqueIndexOnColumnWithCondition column whereC = TableIndex {   idxColumns = [column] , idxInclude = []@@ -118,7 +147,7 @@     if idxUnique then "unique_idx__" else "idx__"   , tname   , "__"-  , mintercalate "__" $ map (asText sanitize) idxColumns+  , mintercalate "__" $ map (asText sanitize . indexColumnName) idxColumns   , if null idxInclude     then ""     else "$$" <> mintercalate "__" (map (asText sanitize) idxInclude)@@ -160,7 +189,13 @@   , indexName tname idx   , " ON" <+> tname   , " USING" <+> (rawSQL (T.pack . show $ idxMethod) ()) <+> "("-  , mintercalate ", " idxColumns+  , mintercalate ", "+      (map+        (\case+          IndexColumn col Nothing -> col+          IndexColumn col (Just opclass) -> col <+> opclass+        )+        idxColumns)   , ")"   , if null idxInclude     then ""

@@ -49,23 +49,13 @@    -- | Migration for creating an index concurrently.   | CreateIndexConcurrentlyMigration-#if __GLASGOW_HASKELL__ >= 806       (RawSQL ()) -- ^ Table name       TableIndex  -- ^ Index-#else-      (RawSQL ())-      TableIndex-#endif    -- | Migration for dropping an index concurrently.   | DropIndexConcurrentlyMigration-#if __GLASGOW_HASKELL__ >= 806       (RawSQL ()) -- ^ Table name       TableIndex  -- ^ Index-#else-      (RawSQL ())-      TableIndex-#endif  -- | Migration object. data Migration m =

@@ -8,10 +8,8 @@   , sqlDropPK   ) where -import Data.Monoid (mconcat) import Data.Monoid.Utils import Database.PostgreSQL.PQTypes-import Prelude import Database.PostgreSQL.PQTypes.Model.Index import Database.PostgreSQL.PQTypes.Utils.NubList 

@@ -19,13 +19,13 @@ import Data.Int import Data.Monoid.Utils import Database.PostgreSQL.PQTypes-import Prelude  import Database.PostgreSQL.PQTypes.Model.Check import Database.PostgreSQL.PQTypes.Model.ColumnType import Database.PostgreSQL.PQTypes.Model.ForeignKey import Database.PostgreSQL.PQTypes.Model.Index import Database.PostgreSQL.PQTypes.Model.PrimaryKey+import Database.PostgreSQL.PQTypes.Model.Trigger  data TableColumn = TableColumn {   colName     :: RawSQL ()@@ -70,6 +70,7 @@ , tblChecks             :: [Check] , tblForeignKeys        :: [ForeignKey] , tblIndexes            :: [TableIndex]+, tblTriggers           :: [Trigger] , tblInitialSetup       :: Maybe TableInitialSetup } @@ -87,6 +88,7 @@ , tblChecks = [] , tblForeignKeys = [] , tblIndexes = []+, tblTriggers = [] , tblInitialSetup = Nothing } 

@@ -0,0 +1,302 @@+-- |+-- 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 {+    tfName   :: RawSQL ()+    -- ^ The function's name.+  , tfSource :: RawSQL ()+    -- ^ The functions's body source code.+} deriving (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.+  f1 == f2 = tfName f1 == tfName 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{..} =+  "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.+--+-- @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 (Eq, Ord, Show)++-- | Trigger.+--+-- @since 1.15.0.0+data Trigger = Trigger {+    triggerTable             :: RawSQL ()+    -- ^ The table that the trigger is associated with.+  , triggerName              :: RawSQL ()+    -- ^ The internal name without any prefixes. Trigger name must be unique among+    -- triggers of same table. See 'triggerMakeName'.+  , 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.+  , triggerDeferrable        :: Bool+    -- ^ Is the trigger @DEFERRABLE@ or @NOT DEFERRABLE@ ?+  , triggerInitiallyDeferred :: Bool+    -- ^ Is the trigger @INITIALLY DEFERRED@ or @INITIALLY IMMEDIATE@ ?+  , triggerWhen              :: Maybe (RawSQL ())+    -- ^ The condition that specifies whether the trigger should fire. Corresponds to the+    -- @WHEN ( __condition__ )@ in the trigger definition.+  , triggerFunction          :: TriggerFunction+    -- ^ The function to execute when the trigger fires.+} deriving (Eq, 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 name tableName = "trg__" <> tableName <> "__" <> 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 name tableName =+  rawSQL (snd . Text.breakOnEnd (unRawSQL tableName <> "__") $ unRawSQL name) ()++triggerEventName :: TriggerEvent -> RawSQL ()+triggerEventName = \case+  TriggerInsert -> "INSERT"+  TriggerUpdate -> "UPDATE"+  TriggerUpdateOf columns -> if null columns+                             then error "UPDATE OF must have columns."+                             else "UPDATE OF" <+> mintercalate ", " columns+  TriggerDelete -> "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{..} =+  "CREATE CONSTRAINT TRIGGER" <+> trgName+    <+> "AFTER" <+> trgEvents+    <+> "ON" <+> triggerTable+    <+> trgTiming+    <+> "FOR EACH ROW"+    <+> trgWhen+    <+> "EXECUTE FUNCTION" <+> trgFunction+    <+> "()"+  where+    trgName+      | triggerName == "" = error "Trigger must have a name."+      | otherwise = triggerMakeName triggerName triggerTable+    trgEvents+      | triggerEvents == Set.empty = error "Trigger must have at least one event."+      | otherwise = mintercalate " OR " . map triggerEventName $ Set.toList triggerEvents+    trgTiming = let deferrable = (if triggerDeferrable then "" else "NOT") <+> "DEFERRABLE"+                    deferred   = if triggerInitiallyDeferred+                                 then "INITIALLY DEFERRED"+                                 else "INITIALLY IMMEDIATE"+                in deferrable <+> deferred+    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+-- @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 tableName = do+  runQuery_ . sqlSelect "pg_trigger t" $ do+    sqlResult "t.tgname::text" -- name+    sqlResult "t.tgtype" -- smallint == int2 => (2 bytes)+    sqlResult "t.tgdeferrable" -- boolean+    sqlResult "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.+    sqlResult "pg_get_triggerdef(t.oid, true)::text"+    sqlResult "p.proname::text" -- name+    sqlResult "p.prosrc" -- text+    sqlResult "c.relname::text"+    sqlJoinOn "pg_proc p" "t.tgfoid = p.oid"+    sqlJoinOn "pg_class c" "c.oid = t.tgrelid"+    sqlWhereEq "t.tgisinternal" False+    sqlWhereEq "c.relname" $ unRawSQL tableName+  fetchMany getTrigger+  where+    getTrigger :: (String, Int16, Bool, Bool, String, String, String, String) -> Trigger+    getTrigger (tgname, tgtype, tgdeferrable, tginitdeferrable, triggerdef, proname, prosrc, tblName) =+      Trigger { triggerTable = tableName'+              , triggerName = triggerBaseName (unsafeSQL tgname) tableName'+              , triggerEvents = trgEvents+              , triggerDeferrable = tgdeferrable+              , triggerInitiallyDeferred = tginitdeferrable+              , triggerWhen = tgrWhen+              , triggerFunction = TriggerFunction (unsafeSQL proname) (unsafeSQL prosrc)+              }+      where+        tableName' :: RawSQL ()+        tableName' = unsafeSQL tblName++        parseBetween :: Text -> Text -> Maybe (RawSQL ())+        parseBetween left right =+          let (prefix, match) = Text.breakOnEnd left $ Text.pack triggerdef+          in if Text.null prefix+             then Nothing+             else Just $ (rawSQL . fst $ Text.breakOn right 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 = parseBetween "WHEN (" ") 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 =+          foldl' (\set (mask, event) ->+                    if testBit tgtype mask+                    then+                      Set.insert+                        (if event == TriggerUpdate+                         then maybe event trgUpdateOf $ parseBetween "UPDATE OF " " ON"+                         else event+                        )+                        set+                    else set+                 )+          Set.empty+          -- Taken from PostgreSQL sources: src/include/catalog/pg_trigger.h:+          [ (2, TriggerInsert) -- #define TRIGGER_TYPE_INSERT (1 << 2)+          , (3, TriggerDelete) -- #define TRIGGER_TYPE_DELETE (1 << 3)+          , (4, TriggerUpdate) -- #define TRIGGER_TYPE_UPDATE (1 << 4)+          ]++        trgUpdateOf :: RawSQL () -> TriggerEvent+        trgUpdateOf columnsSQL =+          let columns = map (unsafeSQL . Text.unpack) . Text.splitOn ", " $ unRawSQL columnsSQL+          in TriggerUpdateOf columns+

@@ -164,20 +164,13 @@   )   where -import Control.Exception.Lifted as E-import Control.Monad.Catch import Control.Monad.State-import Control.Monad.Trans.Control import Data.List import Data.Maybe-import Data.Monoid import Data.Monoid.Utils import Data.String import Data.Typeable import Database.PostgreSQL.PQTypes-import Prelude-import Safe (atMay)-import qualified Text.JSON.Gen as JSON  class Sqlable a where   toSQLCommand :: a -> SQL

@@ -5,8 +5,6 @@     , overNubList     ) where -import Prelude-import Data.Monoid (Monoid(..)) import Data.Typeable  import qualified Text.Read as R

@@ -1,7 +1,5 @@ module Database.PostgreSQL.PQTypes.Versions where -import Prelude- import Database.PostgreSQL.PQTypes.Model  tableVersions :: Table

@@ -1,17 +1,14 @@-module Main-  where+module Main where -import Control.Exception.Lifted as E+import Control.Monad.Catch import Control.Monad.IO.Class-import Control.Monad.Trans.Control- import Data.Either-import Data.Monoid-import Prelude-import qualified Data.Text as T import Data.Typeable import Data.UUID.Types+import qualified Data.Set as Set+import qualified Data.Text as T +import Data.Monoid.Utils import Database.PostgreSQL.PQTypes import Database.PostgreSQL.PQTypes.Checks import Database.PostgreSQL.PQTypes.Model.ColumnType@@ -21,6 +18,7 @@ import Database.PostgreSQL.PQTypes.Model.Migration import Database.PostgreSQL.PQTypes.Model.PrimaryKey import Database.PostgreSQL.PQTypes.Model.Table+import Database.PostgreSQL.PQTypes.Model.Trigger import Database.PostgreSQL.PQTypes.SQL.Builder import Log import Log.Backend.StandardOutput@@ -74,6 +72,7 @@                 , colNullable = False }     ]   , tblPrimaryKey = pkOnColumn "id"+  , tblTriggers = []   }  tableBankSchema2 :: Table@@ -373,7 +372,8 @@ schema2Migrations = schema1Migrations                  ++ [ dropTableMigration   tableWitnessedRobberySchema1                     , dropTableMigration   tableWitnessSchema1-                    , createTableMigration tableUnderArrestSchema2 ]+                    , createTableMigration tableUnderArrestSchema2+                    ]  schema3Tables :: [Table] schema3Tables = [ tableBankSchema3@@ -517,7 +517,7 @@   liftIO $ assertEqual "INSERT ON CONFLICT does nothing (2)" (name, location) details4    -- If NO CONFLICT is not specified, make sure we throw an exception.-  eres :: Either DBException () <- E.try . withSavepoint "testDBSchema" $ do+  eres :: Either DBException () <- try . withSavepoint "testDBSchema" $ do     runQuery_ . sqlInsert "bank" $ do       sqlSet "id" bankId       sqlSet "name" name@@ -566,7 +566,7 @@   liftIO $ assertEqual "INSERT ON CONFLICT does nothing (2)" (name, location) details7    -- If NO CONFLICT is not specified, make sure we throw an exception.-  eres1 :: Either DBException () <- E.try . withSavepoint "testDBSchema" $ do+  eres1 :: Either DBException () <- try . withSavepoint "testDBSchema" $ do     runQuery_ . sqlInsertSelect "bank" "bank" $ do       sqlSetCmd "id" "id"       sqlSetCmd "name" "name"@@ -831,7 +831,326 @@   migrateDBToSchema5  step   testDBSchema5       step +bankTrigger1 :: Trigger+bankTrigger1 =+  Trigger { triggerTable = "bank"+          , triggerName = "trigger_1"+          , triggerEvents = Set.fromList [TriggerInsert]+          , triggerDeferrable = False+          , triggerInitiallyDeferred = False+          , triggerWhen = Nothing+          , triggerFunction = TriggerFunction "function_1" $+                "begin"+            <+> "  perform true;"+            <+> "  return null;"+            <+> "end;"+          } +bankTrigger2 :: Trigger+bankTrigger2 =+  bankTrigger1+  { triggerFunction = TriggerFunction "function_2" $+          "begin"+      <+> "  return null;"+      <+> "end;"+  }++bankTrigger3 :: Trigger+bankTrigger3 =+  Trigger { triggerTable = "bank"+          , triggerName = "trigger_3"+          , triggerEvents = Set.fromList [TriggerInsert, TriggerUpdateOf [unsafeSQL "location"]]+          , triggerDeferrable = True+          , triggerInitiallyDeferred = True+          , triggerWhen = Nothing+          , triggerFunction = TriggerFunction "function_3" $+                "begin"+            <+> "  perform true;"+            <+> "  return null;"+            <+> "end;"+          }++bankTrigger2Proper :: Trigger+bankTrigger2Proper =+  bankTrigger2 { triggerName = "trigger_2" }++testTriggers :: HasCallStack => (String -> TestM ()) -> TestM ()+testTriggers step = do+  step "Running trigger tests..."++  step "create the initial database"+  migrate [tableBankSchema1] [createTableMigration tableBankSchema1]++  do+    let msg = "checkDatabase fails if there are triggers in the database but not in the schema"+        ts = [ tableBankSchema1 { tblVersion = 2+                                , tblTriggers = []+                                }+             ]+        ms = [ createTriggerMigration 1 bankTrigger1 ]+    step msg+    assertException msg $ migrate ts ms++  do+    let msg = "checkDatabase fails if there are triggers in the schema but not in the database"+        ts = [ tableBankSchema1 { tblVersion = 2+                                , tblTriggers = [bankTrigger1]+                                }+             ]+        ms = []+    triggerStep msg $ do+      assertException msg $ migrate ts ms++  do+    let msg = "test succeeds when creating a single trigger"+        ts = [ tableBankSchema1 { tblVersion = 2+                                , tblTriggers = [bankTrigger1]+                                }+             ]+        ms = [ createTriggerMigration 1 bankTrigger1 ]+    triggerStep msg $ do+      assertNoException msg $ migrate ts ms+      verify [bankTrigger1] True++  do+    let msg = "checkDatabase fails if triggers differ in function name"+        ts = [ tableBankSchema1 { tblVersion = 2+                                , tblTriggers = [bankTrigger1]+                                }+             ]+        ms = [ createTriggerMigration 1 bankTrigger2 ]+    triggerStep msg $ do+      assertException msg $ migrate ts ms++  do+    -- Attempt to create the same triggers twice. Should fail with a DBException saying+    -- that function already exists.+    let msg = "database exception is raised if trigger is created twice"+        ts = [ tableBankSchema1 { tblVersion = 3+                                , tblTriggers = [bankTrigger1]+                                }+             ]+        ms = [ createTriggerMigration 1 bankTrigger1+             , createTriggerMigration 2 bankTrigger1+             ]+    triggerStep msg $ do+      assertDBException msg $ migrate ts ms++  do+    let msg = "database exception is raised if triggers only differ in function name"+        ts = [ tableBankSchema1 { tblVersion = 3+                                , tblTriggers = [bankTrigger1, bankTrigger2]+                                }+             ]+        ms = [ createTriggerMigration 1 bankTrigger1+             , createTriggerMigration 2 bankTrigger2+             ]+    triggerStep msg $ do+      assertDBException msg $ migrate ts ms++  do+    let msg = "successfully migrate two triggers"+        ts = [ tableBankSchema1 { tblVersion = 3+                                , tblTriggers = [bankTrigger1, bankTrigger2Proper]+                                }+             ]+        ms = [ createTriggerMigration 1 bankTrigger1+             , createTriggerMigration 2 bankTrigger2Proper+             ]+    triggerStep msg $ do+      assertNoException msg $ migrate ts ms+      verify [bankTrigger1, bankTrigger2Proper] True++  do+    let msg = "database exception is raised if trigger's WHEN is syntactically incorrect"+        trg = bankTrigger1 { triggerWhen = Just "WILL FAIL" }+        ts = [ tableBankSchema1 { tblVersion = 2+                                , tblTriggers = [trg]+                                }+             ]+        ms = [ createTriggerMigration 1 trg ]+    triggerStep msg $ do+      assertDBException msg $ migrate ts ms++  do+    let msg = "database exception is raised if trigger's WHEN uses undefined column"+        trg = bankTrigger1 { triggerWhen = Just "NEW.foobar = 1" }+        ts = [ tableBankSchema1 { tblVersion = 2+                                , tblTriggers = [trg]+                                }+             ]+        ms = [ createTriggerMigration 1 trg ]+    triggerStep msg $ do+      assertDBException msg $ migrate ts ms++  do+    -- This trigger is valid. However, the WHEN clause specified in triggerWhen is not+    -- what gets returned from the database. The decompiled and normalized WHEN clause+    -- from the database looks like this:+    --   new.name <> 'foobar'::text+    -- We simply assert an exception, which presumably comes from the migration framework,+    -- while it should actually be a deeper check for just the differing WHEN+    -- clauses. On the other hand, it's probably good enough as it is.+    -- See the comment for 'getDBTriggers' in src/Database/PostgreSQL/PQTypes/Model/Trigger.hs.+    let msg = "checkDatabase fails if WHEN clauses from database and code differ"+        trg = bankTrigger1 { triggerWhen = Just "NEW.name != 'foobar'" }+        ts = [ tableBankSchema1 { tblVersion = 2+                                , tblTriggers = [trg]+                                }+             ]+        ms = [ createTriggerMigration 1 trg ]+    triggerStep msg $ do+      assertException msg $ migrate ts ms++  do+    let msg = "successfully migrate trigger with valid WHEN"+        trg = bankTrigger1 { triggerWhen = Just "new.name <> 'foobar'::text" }+        ts = [ tableBankSchema1 { tblVersion = 2+                                , tblTriggers = [trg]+                                }+             ]+        ms = [ createTriggerMigration 1 trg ]+    triggerStep msg $ do+      assertNoException msg $ migrate ts ms+      verify [trg] True++  do+    let msg = "successfully migrate trigger that is deferrable"+        trg = bankTrigger1 { triggerDeferrable = True }+        ts = [ tableBankSchema1 { tblVersion = 2+                                , tblTriggers = [trg]+                                }+             ]+        ms = [ createTriggerMigration 1 trg ]+    triggerStep msg $ do+      assertNoException msg $ migrate ts ms+      verify [trg] True++  do+    let msg = "successfully migrate trigger that is deferrable and initially deferred"+        trg = bankTrigger1 { triggerDeferrable = True+                           , triggerInitiallyDeferred = True+                           }+        ts = [ tableBankSchema1 { tblVersion = 2+                                , tblTriggers = [trg]+                                }+             ]+        ms = [ createTriggerMigration 1 trg ]+    triggerStep msg $ do+      assertNoException msg $ migrate ts ms+      verify [trg] True++  do+    let msg = "database exception is raised if trigger is initially deferred but not deferrable"+        trg = bankTrigger1 { triggerDeferrable = False+                           , triggerInitiallyDeferred = True+                           }+        ts = [ tableBankSchema1 { tblVersion = 2+                                , tblTriggers = [trg]+                                }+             ]+        ms = [ createTriggerMigration 1 trg ]+    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+      assertNoException msg $ migrate ts ms+      verify [trg] False++  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++  do+    let msg = "successfully create trigger with multiple events"+        trg = bankTrigger3+        ts = [ tableBankSchema1 { tblVersion = 2+                                , tblTriggers = [trg]+                                }+             ]+        ms = [ createTriggerMigration 1 trg ]+    triggerStep msg $ do+      assertNoException msg $ migrate ts ms+      verify [trg] True++  where+    triggerStep msg rest = do+      recreateTriggerDB+      step msg+      rest++    migrate tables migrations = do+      migrateDatabase defaultExtrasOptions ["pgcrypto"] [] [] tables migrations+      checkDatabase defaultExtrasOptions [] [] tables++    -- Verify that the given triggers are (not) present in the database.+    verify :: (MonadIO m, MonadDB m, HasCallStack) => [Trigger] -> Bool -> m ()+    verify triggers present = do+      dbTriggers <- getDBTriggers "bank"+      let ok = and $ map (`elem` dbTriggers) triggers+          err = "Triggers " <> (if present then "" else "not ") <> "present in the database."+          trans = if present then id else not+      liftIO . assertBool err $ trans ok++    triggerMigration :: MonadDB m => (Trigger -> m ()) -> Int -> Trigger -> Migration m+    triggerMigration fn from trg = Migration+      { mgrTableName = tblName tableBankSchema1+      , mgrFrom = fromIntegral from+      , 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;"+      runSQL_ "DROP FUNCTION IF EXISTS function_1;"+      runSQL_ "DROP FUNCTION IF EXISTS function_2;"+      runSQL_ "DROP TABLE IF EXISTS bank;"+      runSQL_ "DELETE FROM table_versions WHERE name = 'bank'";+      migrate [tableBankSchema1] [createTableMigration tableBankSchema1]+ migrationTest1 :: ConnectionSourceM (LogT IO) -> TestTree migrationTest1 connSource =   testCaseSteps' "Migration test 1" connSource $ \step -> do@@ -839,8 +1158,6 @@    migrationTest1Body  step -  -- freshTestDB         step- -- | Test for behaviour of 'checkDatabase' and 'checkDatabaseAllowUnknownObjects' migrationTest2 :: ConnectionSourceM (LogT IO) -> TestTree migrationTest2 connSource =@@ -962,20 +1279,31 @@    freshTestDB         step -eitherExc :: MonadBaseControl IO m =>-             (SomeException -> m ()) -> (a -> m ()) -> m a -> m ()-eitherExc left right c = (E.try c) >>= either left right+-- | Test triggers.+triggerTests :: ConnectionSourceM (LogT IO) -> TestTree+triggerTests connSource =+  testCaseSteps' "Trigger tests" connSource $ \step -> do+    freshTestDB  step+    testTriggers step +eitherExc :: MonadCatch m => (SomeException -> m ()) -> (a -> m ()) -> m a -> m ()+eitherExc left right c = try c >>= either left right+ assertNoException :: String -> TestM () -> TestM () assertNoException t c = eitherExc   (const $ liftIO $ assertFailure ("Exception thrown for: " ++ t))   (const $ return ()) c  assertException :: String -> TestM () -> TestM ()-assertException   t c = eitherExc+assertException t c = eitherExc   (const $ return ())   (const $ liftIO $ assertFailure ("No exception thrown for: " ++ t)) c +assertDBException :: String -> TestM () -> TestM ()+assertDBException t c =+  try c >>= either (\DBException{} -> pure ())+                   (const . liftIO . assertFailure $ "No DBException thrown for: " ++ t)+ -- | A variant of testCaseSteps that works in TestM monad. testCaseSteps' :: TestName -> ConnectionSourceM (LogT IO)                -> ((String -> TestM ()) -> TestM ())@@ -1000,6 +1328,7 @@                          , migrationTest2 connSource                          , migrationTest3 connSource                          , migrationTest4 connSource+                         , triggerTests connSource                          ]   where     ings =