hpqtypes-extras 1.2.4 → 1.3.0.0

raw patch · 14 files changed

+1717/−389 lines, 14 filesdep +hpqtypes-extrasdep +safedep +tastydep ~basedep ~hpqtypesdep ~lognew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: hpqtypes-extras, safe, tasty, tasty-hunit, transformers

Dependency ranges changed: base, hpqtypes, log

API changes (from Hackage documentation)

Files

• hpqtypes-extras.cabal +36/−5
• src/Database/PostgreSQL/PQTypes/Checks.hs +500/−211
• src/Database/PostgreSQL/PQTypes/Checks/Util.hs +99/−0
• src/Database/PostgreSQL/PQTypes/Migrate.hs +48/−0
• src/Database/PostgreSQL/PQTypes/Model.hs +0/−1
• src/Database/PostgreSQL/PQTypes/Model/Check.hs +1/−1
• src/Database/PostgreSQL/PQTypes/Model/ColumnType.hs +15/−15
• src/Database/PostgreSQL/PQTypes/Model/Domain.hs +11/−10
• src/Database/PostgreSQL/PQTypes/Model/ForeignKey.hs +4/−4
• src/Database/PostgreSQL/PQTypes/Model/Migration.hs +64/−13
• src/Database/PostgreSQL/PQTypes/Model/PrimaryKey.hs +1/−1
• src/Database/PostgreSQL/PQTypes/Model/Table.hs +25/−9
• src/Database/PostgreSQL/PQTypes/SQL/Builder.hs +176/−119
• test/Main.hs +737/−0

@@ -1,24 +1,29 @@ name:                hpqtypes-extras-version:             1.2.4+version:             1.3.0.0 synopsis:            Extra utilities for hpqtypes library description:         The following extras for hpqtypes library:                      .                      * DSL for easy, modular construction of SQL queries.                      .-                     * System for automatic validation and migration of a database schema.+                     * System for automatic validation and migration+                       of a database schema.+ homepage:            https://github.com/scrive/hpqtypes-extras license:             BSD3 license-file:        LICENSE-author:              Scrive+author:              Scrive AB maintainer:          Andrzej Rybczak <andrzej@rybczak.net>,-                     Jonathan Jouty <jonathan@scrive.com>+                     Jonathan Jouty <jonathan@scrive.com>,+                     Mikhail Glushenkov <mikhail@scrive.com>+copyright:           Scrive AB category:            Database build-type:          Simple cabal-version:       >=1.10+tested-with:         GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1  Source-repository head   Type:     git-  Location: git@github.com:scrive/hpqtypes-extras.git+  Location: https://github.com/scrive/hpqtypes-extras.git  library   hs-source-dirs: src@@ -26,6 +31,7 @@   ghc-options: -Wall    exposed-modules: Database.PostgreSQL.PQTypes.Checks+                 , Database.PostgreSQL.PQTypes.Migrate                  , Database.PostgreSQL.PQTypes.Model                  , Database.PostgreSQL.PQTypes.Model.Check                  , Database.PostgreSQL.PQTypes.Model.ColumnType@@ -39,6 +45,7 @@                  , Database.PostgreSQL.PQTypes.Model.Table                  , Database.PostgreSQL.PQTypes.SQL.Builder                  , Database.PostgreSQL.PQTypes.Versions+  other-modules:   Database.PostgreSQL.PQTypes.Checks.Util    build-depends: base < 5                , base16-bytestring@@ -52,6 +59,7 @@                , log > 0.5.2                , monad-control >= 1.0.0.0                , mtl+               , safe                , text                , text-show @@ -71,3 +79,26 @@                     , TupleSections                     , TypeFamilies                     , UndecidableInstances++test-suite  hpqtypes-extras-tests+  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,+                      exceptions,+                      hpqtypes,+                      hpqtypes-extras,+                      lifted-base,+                      log,+                      tasty,+                      tasty-hunit,+                      text,+                      transformers

@@ -1,92 +1,113 @@ module Database.PostgreSQL.PQTypes.Checks (-    migrateDatabase-  , checkDatabase+  -- * Checks+    checkDatabase+  , checkDatabaseAllowUnknownTables   , createTable   , createDomain++  -- * Migrations+  , MigrateOptions(..)+  , migrateDatabase   ) where  import Control.Applicative ((<$>)) import Control.Monad.Catch import Control.Monad.Reader import Data.Int+import Data.Function (on) import Data.Maybe import Data.Monoid import Data.Monoid.Utils+import Data.Ord (comparing)+import Data.Text (Text) import Database.PostgreSQL.PQTypes hiding (def) import Log import Prelude import TextShow-import qualified Data.Foldable as F import qualified Data.List as L import qualified Data.Text as T +import Database.PostgreSQL.PQTypes.Checks.Util+import Database.PostgreSQL.PQTypes.Migrate import Database.PostgreSQL.PQTypes.Model import Database.PostgreSQL.PQTypes.SQL.Builder import Database.PostgreSQL.PQTypes.Versions -newtype ValidationResult = ValidationResult [T.Text] -- ^ list of error messages--instance Monoid ValidationResult where-  mempty = ValidationResult []-  mappend (ValidationResult a) (ValidationResult b) = ValidationResult (a ++ b)--topMessage :: T.Text -> T.Text -> ValidationResult -> ValidationResult-topMessage objtype objname = \case-  ValidationResult [] -> ValidationResult []-  ValidationResult es -> ValidationResult ("There are problems with the" <+> objtype <+> "'" <> objname <> "'" : es)--resultCheck-  :: (MonadLog m, MonadThrow m)-  => ValidationResult-  -> m ()-resultCheck = \case-  ValidationResult [] -> return ()-  ValidationResult msgs -> do-    mapM_ logAttention_ msgs-    error "resultCheck: validation failed"- ---------------------------------------- --- | Runs all checks on a database+-- | Run migrations and check the database structure. migrateDatabase   :: (MonadDB m, MonadLog m, MonadThrow m)-  => [Extension] -> [Domain] -> [Table] -> [Migration m]+  => [MigrateOptions] -> [Extension] -> [Domain] -> [Table] -> [Migration m]   -> m ()-migrateDatabase extensions domains tables migrations = do-  void checkDBTimeZone+migrateDatabase options extensions domains tables migrations = do+  setDBTimeZoneToUTC   mapM_ checkExtension extensions-  checkDBConsistency domains (tableVersions : tables) migrations+  -- 'checkDBConsistency' also performs migrations.+  checkDBConsistency options domains (tableVersions : tables) migrations   resultCheck =<< checkDomainsStructure domains   resultCheck =<< checkDBStructure (tableVersions : tables)-  checkUnknownTables tables+  resultCheck =<< checkTablesWereDropped migrations+  resultCheck =<< checkUnknownTables tables+  resultCheck =<< checkExistenceOfVersionsForTables (tableVersions : tables)    -- everything is OK, commit changes   commit +-- | Run checks on the database structure and whether the database+-- needs to be migrated. Will do a full check of DB structure. checkDatabase-  :: (MonadDB m, MonadLog m, MonadThrow m)-  => [Domain] -> [Table]-  -> m ()-checkDatabase domains tables = do-  versions <- mapM checkTableVersion tables-  let tablesWithVersions = zip tables (map (fromMaybe 0) versions)-  resultCheck . mconcat $ checkVersions tablesWithVersions+  :: forall m . (MonadDB m, MonadLog m, MonadThrow m)+  => [Domain] -> [Table] -> m ()+checkDatabase = checkDatabase_ False++-- | Same as 'checkDatabase', but will not failed if there are+-- additional tables in database.+checkDatabaseAllowUnknownTables+  :: forall m . (MonadDB m, MonadLog m, MonadThrow m)+  => [Domain] -> [Table] -> m ()+checkDatabaseAllowUnknownTables = checkDatabase_ True++checkDatabase_+  :: forall m . (MonadDB m, MonadLog m, MonadThrow m)+  => Bool -> [Domain] -> [Table] -> m ()+checkDatabase_ allowUnknownTables domains tables = do+  tablesWithVersions <- getTableVersions tables++  resultCheck $ checkVersions tablesWithVersions   resultCheck =<< checkDomainsStructure domains   resultCheck =<< checkDBStructure (tableVersions : tables)-  -- check initial setups only after database structure is considered+  when (not $ allowUnknownTables) $ do+    resultCheck =<< checkUnknownTables tables+    resultCheck =<< checkExistenceOfVersionsForTables (tableVersions : tables)++  -- Check initial setups only after database structure is considered   -- consistent as before that some of the checks may fail internally.-  resultCheck . mconcat =<< checkInitialSetups tables+  resultCheck =<< checkInitialSetups tables+   where-    checkVersions = map $ \(t@Table{..}, v) -> ValidationResult $ if-      | tblVersion == v -> []-      | v == 0 -> ["Table '" <> tblNameText t <> "' must be created"]-      | otherwise -> ["Table '" <> tblNameText t <> "' must be migrated" <+> showt v <+> "->" <+> showt tblVersion]+    checkVersions :: [(Table, Int32)] -> ValidationResult+    checkVersions vs = mconcat . map (ValidationResult . checkVersion) $ vs -    checkInitialSetups = mapM $ \t -> case tblInitialSetup t of-      Nothing -> return $ ValidationResult []+    checkVersion :: (Table, Int32) -> [Text]+    checkVersion (t@Table{..}, v)+      | tblVersion == v = []+      | v == 0          = ["Table '" <> tblNameText t <> "' must be created"]+      | otherwise       = ["Table '" <> tblNameText t+                           <> "' must be migrated" <+> showt v <+> "->"+                           <+> showt tblVersion]++    checkInitialSetups :: [Table] -> m ValidationResult+    checkInitialSetups tbls =+      liftM mconcat . mapM (liftM ValidationResult . checkInitialSetup') $ tbls++    checkInitialSetup' :: Table -> m [Text]+    checkInitialSetup' t@Table{..} = case tblInitialSetup of+      Nothing -> return []       Just is -> checkInitialSetup is >>= \case-        True  -> return $ ValidationResult []-        False -> return $ ValidationResult ["Initial setup for table '" <> tblNameText t <> "' is not valid"]+        True  -> return []+        False -> return ["Initial setup for table '"+                          <> tblNameText t <> "' is not valid"]  -- | Return SQL fragment of current catalog within quotes currentCatalog :: (MonadDB m, MonadThrow m) => m (RawSQL ())@@ -111,55 +132,79 @@   where     txtExtension = unRawSQL extension --- |  Checks whether database returns timestamps in UTC-checkDBTimeZone :: (MonadDB m, MonadLog m, MonadThrow m) => m Bool-checkDBTimeZone = do+-- | Check whether the database returns timestamps in UTC, and set the+-- timezone to UTC if it doesn't.+setDBTimeZoneToUTC :: (MonadDB m, MonadLog m, MonadThrow m) => m ()+setDBTimeZoneToUTC = do   runSQL_ "SHOW timezone"   timezone :: String <- fetchOne runIdentity-  if timezone /= "UTC"-    then do-      dbname <- currentCatalog-      logInfo_ $ "Setting '" <> unRawSQL dbname <> "' database to return timestamps in UTC"-      runQuery_ $ "ALTER DATABASE" <+> dbname <+> "SET TIMEZONE = 'UTC'"-      return True-    else return False+  when (timezone /= "UTC") $ do+    dbname <- currentCatalog+    logInfo_ $ "Setting '" <> unRawSQL dbname+      <> "' database to return timestamps in UTC"+    runQuery_ $ "ALTER DATABASE" <+> dbname <+> "SET TIMEZONE = 'UTC'" -checkUnknownTables :: (MonadDB m, MonadLog m) => [Table] -> m ()-checkUnknownTables tables = do+-- | Get the names of all user-defined tables that actually exist in+-- the DB.+getDBTableNames :: (MonadDB m) => m [Text]+getDBTableNames = do   runQuery_ $ sqlSelect "information_schema.tables" $ do     sqlResult "table_name::text"     sqlWhere "table_name <> 'table_versions'"     sqlWhere "table_type = 'BASE TABLE'"     sqlWhere "table_schema NOT IN ('information_schema','pg_catalog')"-  desc <- fetchMany runIdentity-  let absent = desc L.\\ map (unRawSQL . tblName) tables-  when (not (null absent)) $-    mapM_ (\t -> logInfo_ $ "Unknown table:" <+> t) absent -createTable :: MonadDB m => Bool -> Table -> m ()-createTable withConstraints table@Table{..} = do-  -- Create empty table and add the columns.-  runQuery_ $ sqlCreateTable tblName-  runQuery_ $ sqlAlterTable tblName $ map sqlAddColumn tblColumns-  -- Add indexes.-  forM_ tblIndexes $ runQuery_ . sqlCreateIndex tblName-  -- Add all the other constraints if applicable.-  when withConstraints $ createTableConstraints table-  -- Register the table along with its version.-  runQuery_ . sqlInsert "table_versions" $ do-    sqlSet "name" (tblNameText table)-    sqlSet "version" tblVersion+  dbTableNames <- fetchMany runIdentity+  return dbTableNames -createTableConstraints :: MonadDB m => Table -> m ()-createTableConstraints Table{..} = when (not $ null addConstraints) $ do-  runQuery_ $ sqlAlterTable tblName addConstraints+-- | Check that there's a 1-to-1 correspondence between the list of+-- 'Table's and what's actually in the database.+checkUnknownTables :: (MonadDB m, MonadLog m) => [Table] -> m ValidationResult+checkUnknownTables tables = do+  dbTableNames  <- getDBTableNames+  let tableNames = map (unRawSQL . tblName) tables+      absent     = dbTableNames L.\\ tableNames+      notPresent = tableNames   L.\\ dbTableNames++  if (not . null $ absent) || (not . null $ notPresent)+    then do+    mapM_ (logInfo_ . (<+>) "Unknown table:") absent+    mapM_ (logInfo_ . (<+>) "Table not present in the database:") notPresent+    return . ValidationResult $+      (joinedResult "Unknown tables:" absent) +++      (joinedResult "Tables not present in the database:" notPresent)+    else return mempty   where-    addConstraints = concat [-        [sqlAddPK tblName pk | Just pk <- return tblPrimaryKey]-      , map sqlAddCheck tblChecks-      , map (sqlAddFK tblName) tblForeignKeys-      ]+    joinedResult :: Text -> [Text] -> [Text]+    joinedResult _ [] = []+    joinedResult t ts = [ t <+> T.intercalate ", " ts] +-- | Check that there's a 1-to-1 correspondence between the list of+-- 'Table's and what's actually in the table 'table_versions'.+checkExistenceOfVersionsForTables :: (MonadDB m, MonadLog m) => [Table] -> m ValidationResult+checkExistenceOfVersionsForTables tables = do+  runQuery_ $ sqlSelect "table_versions" $ do+    sqlResult "name::text"+  (existingTableNames :: [Text]) <- fetchMany runIdentity++  let tableNames = map (unRawSQL . tblName) tables+      absent     = existingTableNames L.\\ tableNames+      notPresent = tableNames   L.\\ existingTableNames++  if (not . null $ absent) || (not . null $ notPresent)+    then do+    mapM_ (logInfo_ . (<+>) "Unknown entry in 'table_versions':") absent+    mapM_ (logInfo_ . (<+>) "Table not present in the 'table_versions':") notPresent+    return . ValidationResult $+      (joinedResult "Unknown entry in table_versions':"  absent ) +++      (joinedResult "Tables not present in the 'table_versions':" notPresent)+    else return mempty+  where+    joinedResult :: Text -> [Text] -> [Text]+    joinedResult _ [] = []+    joinedResult t ts = [ t <+> T.intercalate ", " ts]++ checkDomainsStructure :: (MonadDB m, MonadThrow m)                       => [Domain] -> m ValidationResult checkDomainsStructure defs = fmap mconcat . forM defs $ \def -> do@@ -171,7 +216,8 @@     sqlResult "ARRAY(SELECT c.conname::text FROM pg_catalog.pg_constraint c WHERE c.contypid = t1.oid ORDER by c.oid)" -- constraint names     sqlResult "ARRAY(SELECT regexp_replace(pg_get_constraintdef(c.oid, true), 'CHECK \\((.*)\\)', '\\1') FROM pg_catalog.pg_constraint c WHERE c.contypid = t1.oid ORDER by c.oid)" -- constraint definitions     sqlWhereEq "t1.typname" $ unRawSQL $ domName def-  mdom <- fetchMaybe $ \(dname, dtype, nullable, defval, cnames, conds) -> Domain {+  mdom <- fetchMaybe $ \(dname, dtype, nullable, defval, cnames, conds) ->+    Domain {     domName = unsafeSQL dname   , domType = dtype   , domNullable = nullable@@ -191,21 +237,35 @@         , compareAttr dom def "checks" domChecks         ]       | otherwise -> mempty-    Nothing -> ValidationResult ["Domain '" <> unRawSQL (domName def) <> "' doesn't exist in the database"]+    Nothing -> ValidationResult ["Domain '" <> unRawSQL (domName def)+                                 <> "' doesn't exist in the database"]   where-    compareAttr :: (Eq a, Show a) => Domain -> Domain -> T.Text -> (Domain -> a) -> ValidationResult+    compareAttr :: (Eq a, Show a)+                => Domain -> Domain -> Text -> (Domain -> a) -> ValidationResult     compareAttr dom def attrname attr       | attr dom == attr def = ValidationResult []-      | otherwise = ValidationResult ["Attribute '" <> attrname <> "' does not match (database:" <+> T.pack (show $ attr dom) <> ", definition:" <+> T.pack (show $ attr def) <> ")"]+      | otherwise = ValidationResult+        [ "Attribute '" <> attrname+          <> "' does not match (database:" <+> T.pack (show $ attr dom)+          <> ", definition:" <+> T.pack (show $ attr def) <> ")" ] -createDomain :: MonadDB m => Domain -> m ()-createDomain dom@Domain{..} = do-  -- create the domain-  runQuery_ $ sqlCreateDomain dom-  -- add constraint checks to the domain-  F.forM_ domChecks $ runQuery_ . sqlAlterDomain domName . sqlAddCheck+-- | Check that the tables that must have been dropped are actually+-- missing from the DB.+checkTablesWereDropped :: (MonadDB m, MonadThrow m) =>+                          [Migration m] -> m ValidationResult+checkTablesWereDropped mgrs = do+  let droppedTableNames = [ mgrTableName mgr+                          | mgr <- mgrs, isDropTableMigration mgr ]+  fmap mconcat . forM droppedTableNames $+    \tblName -> do+      mver <- checkTableVersion (T.unpack . unRawSQL $ tblName)+      return $ if isNothing mver+               then mempty+               else ValidationResult [ "The table '" <> unRawSQL tblName+                                       <> "' that must have been dropped"+                                       <> " is still present in the database." ] --- | Checks whether database is consistent (performs migrations if necessary)+-- | Checks whether database is consistent. checkDBStructure :: forall m. (MonadDB m, MonadThrow m)                  => [Table] -> m ValidationResult checkDBStructure tables = fmap mconcat . forM tables $ \table ->@@ -265,35 +325,53 @@             validateNames $ colName d == colName c           -- bigserial == bigint + autoincrement and there is no           -- distinction between them after table is created.-          , validateTypes $ colType d == colType c || (colType d == BigSerialT && colType c == BigIntT)+          , validateTypes $ colType d == colType c ||+            (colType d == BigSerialT && colType c == BigIntT)           -- there is a problem with default values determined by sequences as           -- they're implicitely specified by db, so let's omit them in such case-          , validateDefaults $ colDefault d == colDefault c || (colDefault d == Nothing && ((T.isPrefixOf "nextval('" . unRawSQL) `liftM` colDefault c) == Just True)+          , validateDefaults $ colDefault d == colDefault c ||+            (colDefault d == Nothing+             && ((T.isPrefixOf "nextval('" . unRawSQL) `liftM` colDefault c)+                == Just True)           , validateNullables $ colNullable d == colNullable c           , checkColumns (n+1) defs cols           ]           where             validateNames True = mempty-            validateNames False = ValidationResult [errorMsg ("no. " <> showt n) "names" (unRawSQL . colName)]+            validateNames False = ValidationResult+              [ errorMsg ("no. " <> showt n) "names" (unRawSQL . colName) ]              validateTypes True = mempty-            validateTypes False = ValidationResult [errorMsg cname "types" (T.pack . show . colType) <+> sqlHint ("TYPE" <+> columnTypeToSQL (colType d))]+            validateTypes False = ValidationResult+              [ errorMsg cname "types" (T.pack . show . colType)+                <+> sqlHint ("TYPE" <+> columnTypeToSQL (colType d)) ]              validateNullables True = mempty-            validateNullables False = ValidationResult [errorMsg cname "nullables" (showt . colNullable) <+> sqlHint ((if colNullable d then "DROP" else "SET") <+> "NOT NULL")]+            validateNullables False = ValidationResult+              [ errorMsg cname "nullables" (showt . colNullable)+                <+> sqlHint ((if colNullable d then "DROP" else "SET")+                              <+> "NOT NULL") ]              validateDefaults True = mempty-            validateDefaults False = ValidationResult [(errorMsg cname "defaults" (showt . fmap unRawSQL . colDefault)) <+> sqlHint set_default]+            validateDefaults False = ValidationResult+              [ (errorMsg cname "defaults" (showt . fmap unRawSQL . colDefault))+                <+> sqlHint set_default ]               where                 set_default = case colDefault d of                   Just v  -> "SET DEFAULT" <+> v                   Nothing -> "DROP DEFAULT"              cname = unRawSQL $ colName d-            errorMsg ident attr f = "Column '" <> ident <> "' differs in" <+> attr <+> "(table:" <+> f c <> ", definition:" <+> f d <> ")."-            sqlHint sql = "(HINT: SQL for making the change is: ALTER TABLE" <+> tblNameText table <+> "ALTER COLUMN" <+> unRawSQL (colName d) <+> unRawSQL sql <> ")"+            errorMsg ident attr f =+              "Column '" <> ident <> "' differs in"+              <+> attr <+> "(table:" <+> f c <> ", definition:" <+> f d <> ")."+            sqlHint sql =+              "(HINT: SQL for making the change is: ALTER TABLE"+              <+> tblNameText table <+> "ALTER COLUMN" <+> unRawSQL (colName d)+              <+> unRawSQL sql <> ")" -        checkPrimaryKey :: Maybe PrimaryKey -> Maybe (PrimaryKey, RawSQL ()) -> ValidationResult+        checkPrimaryKey :: Maybe PrimaryKey -> Maybe (PrimaryKey, RawSQL ())+                        -> ValidationResult         checkPrimaryKey mdef mpk = mconcat [             checkEquality "PRIMARY KEY" def (map fst pk)           , checkNames (const (pkName tblName)) pk@@ -305,100 +383,345 @@         checkChecks :: [Check] -> [Check] -> ValidationResult         checkChecks defs checks = case checkEquality "CHECKs" defs checks of           ValidationResult [] -> ValidationResult []-          ValidationResult errmsgs -> ValidationResult $ errmsgs ++ [" (HINT: If checks are equal modulo number of parentheses/whitespaces used in conditions, just copy and paste expected output into source code)"]+          ValidationResult errmsgs -> ValidationResult $+            errmsgs ++ [" (HINT: If checks are equal modulo number of parentheses/whitespaces used in conditions, just copy and paste expected output into source code)"] -        checkIndexes :: [TableIndex] -> [(TableIndex, RawSQL ())] -> ValidationResult+        checkIndexes :: [TableIndex] -> [(TableIndex, RawSQL ())]+                     -> ValidationResult         checkIndexes defs indexes = mconcat [             checkEquality "INDEXes" defs (map fst indexes)           , checkNames (indexName tblName) indexes           ] -        checkForeignKeys :: [ForeignKey] -> [(ForeignKey, RawSQL ())] -> ValidationResult+        checkForeignKeys :: [ForeignKey] -> [(ForeignKey, RawSQL ())]+                         -> ValidationResult         checkForeignKeys defs fkeys = mconcat [             checkEquality "FOREIGN KEYs" defs (map fst fkeys)           , checkNames (fkName tblName) fkeys           ] --- | Checks whether database is consistent (performs migrations if necessary)+-- | Checks whether database is consistent, performing migrations if+-- necessary. Requires all table names to be in lower case.+--+-- The migrations list must have the following properties:+--   * consecutive 'mgrFrom' numbers+--   * no duplicates+--   * all 'mgrFrom' are less than table version number of the table in+--     the 'tables' list checkDBConsistency   :: forall m. (MonadDB m, MonadLog m, MonadThrow m)-  => [Domain] -> [Table] -> [Migration m]+  => [MigrateOptions] -> [Domain] -> [Table] -> [Migration m]   -> m ()-checkDBConsistency domains tables migrations = do-  -- check if migrations list has the following properties:-  -- - consecutive mgrFrom numbers-  -- - no duplicates-  -- - all mgrFrom are less than table version number of the table in the database (or the just created table)-  forM_ tables $ \table -> do-    let presentMigrationVersions = map mgrFrom $ filter (\m -> tblName (mgrTable m) == tblName table) migrations-        expectedMigrationVersions = reverse $ take (length presentMigrationVersions) $ reverse  [0 .. tblVersion table - 1]-    when (presentMigrationVersions /= expectedMigrationVersions) $ do-      logAttention "Migrations are invalid" $ object [-          "table" .= tblNameText table-        , "migration_versions" .= presentMigrationVersions-        , "expected_migration_versions" .= expectedMigrationVersions-        ]-      error $ "checkDBConsistency: invalid migrations for table" <+> tblNameString table+checkDBConsistency options domains tables migrations = do+  -- Check the validity of the migrations list.+  validateMigrations+  validateDropTableMigrations -  versions <- mapM checkTableVersion tables-  let tablesWithVersions = zip tables (map (fromMaybe 0) versions)+  -- Load version numbers of the tables that actually exist in the DB.+  tablesWithVersions   <- getTableVersions $ tables+  dbTablesWithVersions <- getDBTableVersions    if all ((==) 0 . snd) tablesWithVersions++    -- No tables are present, create everything from scratch.     then do-      -- No tables are present, create everything from scratch.+      createDBSchema+      initializeDB++    -- Migration mode.+    else do+      -- Additional validity checks for the migrations list.+      validateMigrationsAgainstDB [ (tblName table, tblVersion table, actualVer)+                                  | (table, actualVer) <- tablesWithVersions ]+      validateDropTableMigrationsAgainstDB dbTablesWithVersions+      -- Run migrations, if necessary.+      runMigrations dbTablesWithVersions++  where++    errorInvalidMigrations :: [RawSQL ()] -> a+    errorInvalidMigrations tblNames =+      error $ "checkDBConsistency: invalid migrations for tables"+              <+> (L.intercalate ", " $ map (T.unpack . unRawSQL) tblNames)++    checkMigrationsListValidity :: Table -> [Int32] -> [Int32] -> m ()+    checkMigrationsListValidity table presentMigrationVersions+      expectedMigrationVersions = do+      when (presentMigrationVersions /= expectedMigrationVersions) $ do+        logAttention "Migrations are invalid" $ object [+            "table"                       .= tblNameText table+          , "migration_versions"          .= presentMigrationVersions+          , "expected_migration_versions" .= expectedMigrationVersions+          ]+        errorInvalidMigrations [tblName $ table]++    validateMigrations :: m ()+    validateMigrations = forM_ tables $ \table -> do+      let presentMigrationVersions+            = [ mgrFrom | Migration{..} <- migrations+                        , mgrTableName == tblName table ]+          expectedMigrationVersions+            = reverse $ take (length presentMigrationVersions) $+              reverse  [0 .. tblVersion table - 1]+      checkMigrationsListValidity table presentMigrationVersions+        expectedMigrationVersions++    validateDropTableMigrations :: m ()+    validateDropTableMigrations = do+      let droppedTableNames =+            [ mgrTableName $ mgr | mgr <- migrations+                                 , isDropTableMigration mgr ]+          tableNames =+            [ tblName tbl | tbl <- tables ]++      -- Check that the intersection between the 'tables' list and+      -- dropped tables is empty.+      let intersection = L.intersect droppedTableNames tableNames+      when (not . null $ intersection) $ do+          logAttention ("The intersection between tables "+                        <> "and dropped tables is not empty")+            $ object+            [ "intersection" .= map unRawSQL intersection ]+          errorInvalidMigrations [ tblName tbl | tbl <- tables+                                               , tblName tbl `elem` intersection ]++      -- Check that if a list of migrations for a given table has a+      -- drop table migration, it is unique and is the last migration+      -- in the list.+      let migrationsByTable     = L.groupBy ((==) `on` mgrTableName)+                                  migrations+          dropMigrationLists    = [ mgrs | mgrs <- migrationsByTable+                                         , any isDropTableMigration mgrs ]+          invalidMigrationLists =+            [ mgrs | mgrs <- dropMigrationLists+                   , (not . isDropTableMigration . last $ mgrs) ||+                     (length . filter isDropTableMigration $ mgrs) > 1 ]++      when (not . null $ invalidMigrationLists) $ do+        let tablesWithInvalidMigrationLists =+              [ mgrTableName mgr | mgrs <- invalidMigrationLists+                                 , let mgr = head mgrs ]+        logAttention ("Migration lists for some tables contain "+                      <> "either multiple drop table migrations or "+                      <> "a drop table migration in non-tail position.")+          $ object [ "tables" .= [ unRawSQL tblName+                                 | tblName <- tablesWithInvalidMigrationLists ] ]+        errorInvalidMigrations tablesWithInvalidMigrationLists++    createDBSchema :: m ()+    createDBSchema = do       logInfo_ "Creating domains..."       mapM_ createDomain domains-      logInfo_ "Creating tables..."       -- Create all tables with no constraints first to allow cyclic references.+      logInfo_ "Creating tables..."       mapM_ (createTable False) tables       logInfo_ "Creating table constraints..."       mapM_ createTableConstraints tables       logInfo_ "Done."++    initializeDB :: m ()+    initializeDB = do       logInfo_ "Running initial setup for tables..."       forM_ tables $ \t -> case tblInitialSetup t of         Nothing -> return ()         Just tis -> do-          logInfo_ $ "Intializing" <+> tblNameText t <> "..."+          logInfo_ $ "Initializing" <+> tblNameText t <> "..."           initialSetup tis       logInfo_ "Done." -    else do-      -- Migration mode.-      forM_ tablesWithVersions $ \(table, ver) -> when (tblVersion table /= ver) $ do-        case L.find (\m -> tblNameString (mgrTable m) == tblNameString table) migrations of-          Nothing -> do-            error $ "checkDBConsistency: no migrations found for table '" ++ tblNameString table ++ "', cannot migrate " ++ show ver ++ " -> " ++ show (tblVersion table)-          Just m | mgrFrom m > ver -> do-            error $ "checkDBConsistency: earliest migration for table '" ++ tblNameString table ++ "' is from version " ++ show (mgrFrom m) ++ ", cannot migrate " ++ show ver ++ " -> " ++ show (tblVersion table)-          Just _ -> return ()+    -- | Input is a list of (table name, expected version, actual version) triples.+    validateMigrationsAgainstDB :: [(RawSQL (), Int32, Int32)] -> m ()+    validateMigrationsAgainstDB tablesWithVersions+      = forM_ tablesWithVersions $ \(tableName, expectedVer, actualVer) ->+        when (expectedVer /= actualVer) $+        case [ m | m@Migration{..} <- migrations+                 , mgrTableName == tableName ] of+          [] ->+            error $ "checkDBConsistency: no migrations found for table '"+              ++ (T.unpack . unRawSQL $ tableName) ++ "', cannot migrate "+              ++ show actualVer ++ " -> " ++ show expectedVer+          (m:_) | mgrFrom m > actualVer ->+                  error $ "checkDBConsistency: earliest migration for table '"+                    ++ (T.unpack . unRawSQL $ tableName) ++ "' is from version "+                    ++ show (mgrFrom m) ++ ", cannot migrate "+                    ++ show actualVer ++ " -> " ++ show expectedVer+                | otherwise -> return () -      let migrationsToRun = filter (\m -> any (\(t, from) -> tblName (mgrTable m) == tblName t && mgrFrom m >= from) tablesWithVersions) migrations+    validateDropTableMigrationsAgainstDB :: [(Text, Int32)] -> m ()+    validateDropTableMigrationsAgainstDB dbTablesWithVersions = do+      let dbTablesToDropWithVersions =+            [ (tblName, mgrFrom mgr, fromJust mver)+            | mgr <- migrations+            , isDropTableMigration mgr+            , let tblName = mgrTableName mgr+            , let mver = lookup (unRawSQL tblName) $ dbTablesWithVersions+            , isJust mver ]+      forM_ dbTablesToDropWithVersions $ \(tblName, fromVer, ver) ->+        when (fromVer /= ver) $+          -- In case when the table we're going to drop is an old+          -- version, check that there are migrations that bring it to a new one.+          validateMigrationsAgainstDB [(tblName, fromVer, ver)] -      -- Run migrations, if necessary.+    findMigrationsToRun :: [(Text, Int32)] -> [Migration m]+    findMigrationsToRun dbTablesWithVersions =+      let tableNamesToDrop = [ mgrTableName mgr | mgr <- migrations+                                                , isDropTableMigration mgr ]+          droppedEventually :: Migration m -> Bool+          droppedEventually mgr = mgrTableName mgr `elem` tableNamesToDrop++          lookupVer :: Migration m -> Maybe Int32+          lookupVer mgr = lookup (unRawSQL $ mgrTableName mgr) dbTablesWithVersions++          tableDoesNotExist = isNothing . lookupVer++          -- The idea here is that we find the first migration we need+          -- to run and then just run all migrations in order after+          -- that one.+          migrationsToRun' = dropWhile+            (\mgr ->+               case lookupVer mgr of+                 -- Table doesn't exist in the DB. If it's a create+                 -- table migration and we're not going to drop the+                 -- table afterwards, this is our starting point.+                 Nothing -> not $+                            (mgrFrom mgr == 0) && (not . droppedEventually $ mgr)+                 -- Table exists in the DB. Run only those migrations+                 -- that have mgrFrom >= table version in the DB.+                 Just ver -> not $+                             mgrFrom mgr >= ver)+            migrations++          -- Special case: also include migrations for tables that do+          -- not exist in the DB and ARE going to be dropped if they+          -- come as a consecutive list before the starting point that+          -- we've found.+          --+          -- Case in point: createTable t, doSomethingTo t,+          -- doSomethingTo t1, dropTable t.+          l = length migrationsToRun'+          initialMigrations = drop l $ reverse migrations+          additionalMigrations = takeWhile+            (\mgr -> droppedEventually mgr && tableDoesNotExist mgr)+            initialMigrations+          migrationsToRun = (reverse additionalMigrations) ++ migrationsToRun'+      in migrationsToRun++    runMigration :: (Migration m) -> m ()+    runMigration Migration{..} = do+      case mgrAction of+        StandardMigration mgrDo -> do+          logInfo_ $ arrListTable mgrTableName <> showt mgrFrom <+> "->"+            <+> showt (succ mgrFrom)+          mgrDo+          runQuery_ $ sqlUpdate "table_versions" $ do+            sqlSet "version"  (succ mgrFrom)+            sqlWhereEq "name" (T.unpack . unRawSQL $ mgrTableName)++        DropTableMigration mgrDropTableMode -> do+          logInfo_ $ arrListTable mgrTableName <> "drop table"+          runQuery_ $ sqlDropTable mgrTableName+            mgrDropTableMode+          runQuery_ $ sqlDelete "table_versions" $ do+            sqlWhereEq "name" (T.unpack . unRawSQL $ mgrTableName)++    runMigrations :: [(Text, Int32)] -> m ()+    runMigrations dbTablesWithVersions = do+      let migrationsToRun = findMigrationsToRun dbTablesWithVersions+      validateMigrationsToRun migrationsToRun dbTablesWithVersions       when (not . null $ migrationsToRun) $ do         logInfo_ "Running migrations..."-        forM_ migrationsToRun $ \migration -> do-          logInfo_ $ arrListTable (mgrTable migration) <> showt (mgrFrom migration) <+> "->" <+> showt (succ $ mgrFrom migration)-          mgrDo migration-          runQuery_ $ sqlUpdate "table_versions" $ do-            sqlSet "version" $ succ (mgrFrom migration)-            sqlWhereEq "name" $ tblNameString (mgrTable migration)+        forM_ migrationsToRun $ \mgr -> do+          runMigration mgr++          when (ForceCommitAfterEveryMigration `elem` options) $ do+            logInfo_ $ "Forcing commit after migraton"+              <> " and starting new transaction..."+            commit+            begin+            logInfo_ $ "Forcing commit after migraton"+              <> " and starting new transaction... done."+            logInfo_ "!IMPORTANT! Database has been permanently changed"         logInfo_ "Running migrations... done." -checkTableVersion :: (MonadDB m, MonadThrow m) => Table -> m (Maybe Int32)-checkTableVersion table = do+    validateMigrationsToRun :: [Migration m] -> [(Text, Int32)] -> m ()+    validateMigrationsToRun migrationsToRun dbTablesWithVersions = do+      let migrationsToRunGrouped =+            L.groupBy ((==) `on` mgrTableName) .+            L.sortBy (comparing mgrTableName) $ -- NB: stable sort+            migrationsToRun+          mgrGroupsNotInDB =+            [ mgrGroup+            | mgrGroup <- migrationsToRunGrouped+            , isNothing $+              lookup (unRawSQL . mgrTableName . head $ mgrGroup)+              dbTablesWithVersions+            ]+          groupsStartingWithDropTable =+            [ mgrGroup+            | mgrGroup <- mgrGroupsNotInDB+            , isDropTableMigration $ head mgrGroup+            ]+          groupsNotStartingWithCreateTable =+            [ mgrGroup+            | mgrGroup <- mgrGroupsNotInDB+            , mgrFrom (head mgrGroup) /= 0+            ]+          tblNames grps =+            [ mgrTableName . head $ grp | grp <- grps ]++      when (not . null $ groupsStartingWithDropTable) $ do+        let tnms = tblNames groupsStartingWithDropTable+        logAttention "There are drop table migrations for non-existing tables."+          $ object [ "tables" .= [ unRawSQL tn | tn <- tnms ] ]+        errorInvalidMigrations tnms++      -- NB: the following check can break if we allow renaming tables.+      when (not . null $ groupsNotStartingWithCreateTable) $ do+        let tnms = tblNames groupsNotStartingWithCreateTable+        logAttention+          ("Some tables haven't been created yet, but" <>+            "their migration lists don't start with a create table migration.")+          $ object [ "tables" .=  [ unRawSQL tn | tn <- tnms ] ]+        errorInvalidMigrations tnms+++-- | Associate each table in the list with its version as it exists in+-- the DB, or 0 if it's missing from the DB.+getTableVersions :: (MonadDB m, MonadThrow m) => [Table] -> m [(Table, Int32)]+getTableVersions tbls =+  sequence+  [ (\mver -> (tbl, fromMaybe 0 mver)) <$> checkTableVersion (tblNameString tbl)+  | tbl <- tbls ]++-- | Like 'getTableVersions', but for all user-defined tables that+-- actually exist in the DB.+getDBTableVersions :: (MonadDB m, MonadThrow m) => m [(Text, Int32)]+getDBTableVersions = do+  dbTableNames <- getDBTableNames+  sequence+    [ (\mver -> (name, fromMaybe 0 mver)) <$> checkTableVersion (T.unpack name)+    | name <- dbTableNames ]++-- | Check whether the table exists in the DB, and return 'Just' its+-- version if it does, or 'Nothing' if it doesn't.+checkTableVersion :: (MonadDB m, MonadThrow m) => String -> m (Maybe Int32)+checkTableVersion tblName = do   doesExist <- runQuery01 . sqlSelect "pg_catalog.pg_class c" $ do     sqlResult "TRUE"     sqlLeftJoinOn "pg_catalog.pg_namespace n" "n.oid = c.relnamespace"-    sqlWhereEq "c.relname" $ tblNameString table+    sqlWhereEq "c.relname" $ tblName     sqlWhere "pg_catalog.pg_table_is_visible(c.oid)"   if doesExist     then do-      runQuery_ $ "SELECT version FROM table_versions WHERE name =" <?> tblNameString table+      runQuery_ $ "SELECT version FROM table_versions WHERE name ="+        <?> tblName       mver <- fetchMaybe runIdentity       case mver of         Just ver -> return $ Just ver-        Nothing  -> error $ "checkTableVersion: table '" ++ tblNameString table ++ "' is present in the database, but there is no corresponding version info in 'table_versions'."+        Nothing  -> error $ "checkTableVersion: table '"+          ++ tblName+          ++ "' is present in the database, "+          ++ "but there is no corresponding version info in 'table_versions'."     else do       return Nothing @@ -417,7 +740,8 @@ sqlGetPrimaryKey :: Table -> SQL sqlGetPrimaryKey table = toSQLCommand . sqlSelect "pg_catalog.pg_constraint c" $ do   sqlResult "c.conname::text"-  sqlResult "array(SELECT a.attname::text FROM pg_catalog.pg_attribute a WHERE a.attrelid = c.conrelid AND a.attnum = ANY (c.conkey)) as columns" -- list of affected columns+  -- list of affected columns+  sqlResult "array(SELECT a.attname::text FROM pg_catalog.pg_attribute a WHERE a.attrelid = c.conrelid AND a.attnum = ANY (c.conkey)) as columns"   sqlWhereEq "c.contype" 'p'   sqlWhereEqSql "c.conrelid" $ sqlGetTableID table @@ -447,9 +771,11 @@   sqlResult "c.relname::text" -- index name   sqlResult $ "ARRAY(" <> selectCoordinates <> ")" -- array of index coordinates   sqlResult "i.indisunique" -- is it unique?-  sqlResult "pg_catalog.pg_get_expr(i.indpred, i.indrelid, true)" -- if partial, get constraint def+  -- if partial, get constraint def+  sqlResult "pg_catalog.pg_get_expr(i.indpred, i.indrelid, true)"   sqlJoinOn "pg_catalog.pg_index i" "c.oid = i.indexrelid"-  sqlLeftJoinOn "pg_catalog.pg_constraint r" "r.conrelid = i.indrelid AND r.conindid = i.indexrelid"+  sqlLeftJoinOn "pg_catalog.pg_constraint r"+    "r.conrelid = i.indrelid AND r.conindid = i.indexrelid"   sqlWhereEqSql "i.indrelid" $ sqlGetTableID table   sqlWhereIsNULL "r.contype" -- fetch only "pure" indexes   where@@ -465,7 +791,8 @@       , "SELECT name FROM coordinates WHERE k > 0"       ] -fetchTableIndex :: (String, Array1 String, Bool, Maybe String) -> (TableIndex, RawSQL ())+fetchTableIndex :: (String, Array1 String, Bool, Maybe String)+                -> (TableIndex, RawSQL ()) fetchTableIndex (name, Array1 columns, unique, mconstraint) = (TableIndex {   idxColumns = map unsafeSQL columns , idxUnique = unique@@ -475,11 +802,17 @@ -- *** FOREIGN KEYS ***  sqlGetForeignKeys :: Table -> SQL-sqlGetForeignKeys table = toSQLCommand . sqlSelect "pg_catalog.pg_constraint r" $ do+sqlGetForeignKeys table = toSQLCommand+                          . sqlSelect "pg_catalog.pg_constraint r" $ do   sqlResult "r.conname::text" -- fk name-  sqlResult $ "ARRAY(SELECT a.attname::text FROM pg_catalog.pg_attribute a JOIN (" <> unnestWithOrdinality "r.conkey" <> ") conkeys ON (a.attnum = conkeys.item) WHERE a.attrelid = r.conrelid ORDER BY conkeys.n)" -- constrained columns+  sqlResult $+    "ARRAY(SELECT a.attname::text FROM pg_catalog.pg_attribute a JOIN ("+    <> unnestWithOrdinality "r.conkey"+    <> ") conkeys ON (a.attnum = conkeys.item) WHERE a.attrelid = r.conrelid ORDER BY conkeys.n)" -- constrained columns   sqlResult "c.relname::text" -- referenced table-  sqlResult $ "ARRAY(SELECT a.attname::text FROM pg_catalog.pg_attribute a JOIN (" <> unnestWithOrdinality "r.confkey" <> ") confkeys ON (a.attnum = confkeys.item) WHERE a.attrelid = r.confrelid ORDER BY confkeys.n)" -- referenced columns+  sqlResult $ "ARRAY(SELECT a.attname::text FROM pg_catalog.pg_attribute a JOIN ("+    <> unnestWithOrdinality "r.confkey"+    <> ") confkeys ON (a.attnum = confkeys.item) WHERE a.attrelid = r.confrelid ORDER BY confkeys.n)" -- referenced columns   sqlResult "r.confupdtype" -- on update   sqlResult "r.confdeltype" -- on delete   sqlResult "r.condeferrable" -- deferrable?@@ -489,10 +822,16 @@   sqlWhereEq "r.contype" 'f'   where     unnestWithOrdinality :: RawSQL () -> SQL-    unnestWithOrdinality arr = "SELECT n, " <> raw arr <> "[n] AS item FROM generate_subscripts(" <> raw arr <> ", 1) AS n"+    unnestWithOrdinality arr =+      "SELECT n, " <> raw arr+      <> "[n] AS item FROM generate_subscripts(" <> raw arr <> ", 1) AS n" -fetchForeignKey :: (String, Array1 String, String, Array1 String, Char, Char, Bool, Bool) -> (ForeignKey, RawSQL ())-fetchForeignKey (name, Array1 columns, reftable, Array1 refcolumns, on_update, on_delete, deferrable, deferred) = (ForeignKey {+fetchForeignKey ::+  (String, Array1 String, String, Array1 String, Char, Char, Bool, Bool)+  -> (ForeignKey, RawSQL ())+fetchForeignKey+  ( name, Array1 columns, reftable, Array1 refcolumns+  , on_update, on_delete, deferrable, deferred ) = (ForeignKey {   fkColumns = map unsafeSQL columns , fkRefTable = unsafeSQL reftable , fkRefColumns = map unsafeSQL refcolumns@@ -509,53 +848,3 @@       'n' -> ForeignKeySetNull       'd' -> ForeignKeySetDefault       _   -> error $ "fetchForeignKey: invalid foreign key action code: " ++ show c---- *** UTILS ***--tblNameText :: Table -> T.Text-tblNameText = unRawSQL . tblName--tblNameString :: Table -> String-tblNameString = T.unpack . tblNameText--checkEquality :: (Eq t, Show t) => T.Text -> [t] -> [t] -> ValidationResult-checkEquality pname defs props = case (defs L.\\ props, props L.\\ defs) of-  ([], []) -> mempty-  (def_diff, db_diff) -> ValidationResult [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-    , ")."-    ]]--checkNames :: Show t => (t -> RawSQL ()) -> [(t, RawSQL ())] -> ValidationResult-checkNames prop_name = mconcat . map check-  where-    check (prop, name) = case prop_name prop of-      pname-        | pname == name -> mempty-        | otherwise -> ValidationResult [mconcat [-            "Property "-          , T.pack $ show prop-          , " has invalid name (expected: "-          , unRawSQL pname-          , ", given: "-          , unRawSQL name-          , ")."-          ]]--tableHasLess :: Show t => T.Text -> t -> T.Text-tableHasLess ptype missing = "Table in the database has *less*" <+> ptype <+> "than its definition (missing:" <+> T.pack (show missing) <> ")"--tableHasMore :: Show t => T.Text -> t -> T.Text-tableHasMore ptype extra = "Table in the database has *more*" <+> ptype <+> "than its definition (extra:" <+> T.pack (show extra) <> ")"--arrListTable :: Table -> T.Text-arrListTable table = " ->" <+> tblNameText table <> ": "

@@ -0,0 +1,99 @@+module Database.PostgreSQL.PQTypes.Checks.Util (+  ValidationResult(..),+  resultCheck,+  topMessage,+  tblNameText,+  tblNameString,+  checkEquality,+  checkNames,+  tableHasLess,+  tableHasMore,+  arrListTable+  ) where++import Control.Monad.Catch+import Data.Monoid+import Data.Monoid.Utils+import Data.Text (Text)+import Log+import TextShow+import qualified Data.List as L+import qualified Data.Text as T++import Database.PostgreSQL.PQTypes.Model+import Database.PostgreSQL.PQTypes++-- | A (potentially empty) list of error messages.+newtype ValidationResult = ValidationResult [Text]++instance Monoid ValidationResult where+  mempty = ValidationResult []+  mappend (ValidationResult a) (ValidationResult b) = ValidationResult (a ++ b)++topMessage :: Text -> Text -> ValidationResult -> ValidationResult+topMessage objtype objname = \case+  ValidationResult [] -> ValidationResult []+  ValidationResult es -> ValidationResult+    ("There are problems with the" <+> objtype <+> "'" <> objname <> "'" : es)++resultCheck+  :: (MonadLog m, MonadThrow m)+  => ValidationResult+  -> m ()+resultCheck = \case+  ValidationResult [] -> return ()+  ValidationResult msgs -> do+    mapM_ logAttention_ msgs+    error "resultCheck: validation failed"++tblNameText :: Table -> Text+tblNameText = unRawSQL . tblName++tblNameString :: Table -> String+tblNameString = T.unpack . tblNameText++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) -> ValidationResult [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+    , ")."+    ]]++checkNames :: Show t => (t -> RawSQL ()) -> [(t, RawSQL ())] -> ValidationResult+checkNames prop_name = mconcat . map check+  where+    check (prop, name) = case prop_name prop of+      pname+        | pname == name -> mempty+        | otherwise -> ValidationResult [mconcat [+            "Property "+          , T.pack $ show prop+          , " has invalid name (expected: "+          , unRawSQL pname+          , ", given: "+          , unRawSQL name+          , ")."+          ]]++tableHasLess :: Show t => Text -> t -> Text+tableHasLess ptype missing =+  "Table in the database has *less*" <+> ptype <+>+  "than its definition (missing:" <+> T.pack (show missing) <> ")"++tableHasMore :: Show t => Text -> t -> Text+tableHasMore ptype extra =+  "Table in the database has *more*" <+> ptype <+>+  "than its definition (extra:" <+> T.pack (show extra) <> ")"++arrListTable :: RawSQL () -> Text+arrListTable tableName = " ->" <+> unRawSQL tableName <> ": "

@@ -0,0 +1,48 @@+module Database.PostgreSQL.PQTypes.Migrate (+  MigrateOptions(..),+  createDomain,+  createTable,+  createTableConstraints+  ) where++import Control.Monad+import qualified Data.Foldable as F++import Database.PostgreSQL.PQTypes hiding (def)+import Database.PostgreSQL.PQTypes.Checks.Util+import Database.PostgreSQL.PQTypes.Model+import Database.PostgreSQL.PQTypes.SQL.Builder++data MigrateOptions = ForceCommitAfterEveryMigration+  deriving Eq++createDomain :: MonadDB m => Domain -> m ()+createDomain dom@Domain{..} = do+  -- create the domain+  runQuery_ $ sqlCreateDomain dom+  -- add constraint checks to the domain+  F.forM_ domChecks $ runQuery_ . sqlAlterDomain domName . sqlAddCheck++createTable :: MonadDB m => Bool -> Table -> m ()+createTable withConstraints table@Table{..} = do+  -- Create empty table and add the columns.+  runQuery_ $ sqlCreateTable tblName+  runQuery_ $ sqlAlterTable tblName $ map sqlAddColumn tblColumns+  -- Add indexes.+  forM_ tblIndexes $ runQuery_ . sqlCreateIndex tblName+  -- Add all the other constraints if applicable.+  when withConstraints $ createTableConstraints table+  -- Register the table along with its version.+  runQuery_ . sqlInsert "table_versions" $ do+    sqlSet "name" (tblNameText table)+    sqlSet "version" tblVersion++createTableConstraints :: MonadDB m => Table -> m ()+createTableConstraints Table{..} = when (not $ null addConstraints) $ do+  runQuery_ $ sqlAlterTable tblName addConstraints+  where+    addConstraints = concat [+        [sqlAddPK tblName pk | Just pk <- return tblPrimaryKey]+      , map sqlAddCheck tblChecks+      , map (sqlAddFK tblName) tblForeignKeys+      ]

@@ -21,4 +21,3 @@ import Database.PostgreSQL.PQTypes.Model.Migration import Database.PostgreSQL.PQTypes.Model.PrimaryKey import Database.PostgreSQL.PQTypes.Model.Table-

@@ -9,7 +9,7 @@ import Prelude  data Check = Check {-  chkName :: RawSQL ()+  chkName      :: RawSQL () , chkCondition :: RawSQL () } deriving (Eq, Ord, Show) 

@@ -54,19 +54,19 @@           | otherwise -> CustomT $ rawSQL tname ()  columnTypeToSQL :: ColumnType -> RawSQL ()-columnTypeToSQL BigIntT = "BIGINT"-columnTypeToSQL BigSerialT = "BIGSERIAL"-columnTypeToSQL BinaryT = "BYTEA"-columnTypeToSQL BoolT = "BOOLEAN"-columnTypeToSQL DateT = "DATE"-columnTypeToSQL DoubleT = "DOUBLE PRECISION"-columnTypeToSQL IntegerT = "INTEGER"-columnTypeToSQL IntervalT = "INTERVAL"-columnTypeToSQL JsonT = "JSON"-columnTypeToSQL JsonbT = "JSONB"-columnTypeToSQL SmallIntT = "SMALLINT"-columnTypeToSQL TextT = "TEXT"+columnTypeToSQL BigIntT            = "BIGINT"+columnTypeToSQL BigSerialT         = "BIGSERIAL"+columnTypeToSQL BinaryT            = "BYTEA"+columnTypeToSQL BoolT              = "BOOLEAN"+columnTypeToSQL DateT              = "DATE"+columnTypeToSQL DoubleT            = "DOUBLE PRECISION"+columnTypeToSQL IntegerT           = "INTEGER"+columnTypeToSQL IntervalT          = "INTERVAL"+columnTypeToSQL JsonT              = "JSON"+columnTypeToSQL JsonbT             = "JSONB"+columnTypeToSQL SmallIntT          = "SMALLINT"+columnTypeToSQL TextT              = "TEXT" columnTypeToSQL TimestampWithZoneT = "TIMESTAMPTZ"-columnTypeToSQL XmlT = "XML"-columnTypeToSQL (ArrayT t) = columnTypeToSQL t <> "[]"-columnTypeToSQL (CustomT tname) = tname+columnTypeToSQL XmlT               = "XML"+columnTypeToSQL (ArrayT t)         = columnTypeToSQL t <> "[]"+columnTypeToSQL (CustomT tname)    = tname

@@ -29,12 +29,13 @@ -- -- 1) One of the tables that use the domain should migrate it. -- 2) The table that requires data modification should migrate it.--- 3) One of the tables that require data modification should migrate it.--- Note that modification of constraints may conflict with the data in--- the other tables. In this case, these constraints should be created--- as NOT VALID (see http://www.postgresql.org/docs/current/static/sql-alterdomain.html--- for more info) and VALIDATEd in the migration of the last table with--- the conflicting data.+-- 3) One of the tables that require data modification should migrate+-- it.  Note that modification of constraints may conflict with the+-- data in the other tables. In this case, these constraints should be+-- created as NOT VALID (see+-- http://www.postgresql.org/docs/current/static/sql-alterdomain.html+-- for more info) and VALIDATEd in the migration of the last table+-- with the conflicting data. -- -- TODO: the proper solution to this is to version the domains to be -- able to handle (1) and the first and last part of (3) by migrating@@ -51,17 +52,17 @@  data Domain = Domain {   -- | Name of the domain.-  domName :: RawSQL ()+  domName     :: RawSQL ()   -- | Type of the domain.-, domType :: ColumnType+, domType     :: ColumnType   -- | Defines whether the domain value can be NULL.   -- *Cannot* be superseded by a table column definition. , domNullable :: Bool   -- Default value for the domain. *Can* be   -- superseded by a table column definition.-, domDefault :: Maybe (RawSQL ())+, domDefault  :: Maybe (RawSQL ())   -- Set of constraint checks on the domain.-, domChecks :: Set Check+, domChecks   :: Set Check } deriving (Eq, Ord, Show)  mkChecks :: [Check] -> Set Check

@@ -72,10 +72,10 @@   , " INITIALLY" <+> if fkDeferred then "DEFERRED" else "IMMEDIATE"   ]   where-    foreignKeyActionToSQL ForeignKeyNoAction = "NO ACTION"-    foreignKeyActionToSQL ForeignKeyRestrict = "RESTRICT"-    foreignKeyActionToSQL ForeignKeyCascade = "CASCADE"-    foreignKeyActionToSQL ForeignKeySetNull = "SET NULL"+    foreignKeyActionToSQL ForeignKeyNoAction   = "NO ACTION"+    foreignKeyActionToSQL ForeignKeyRestrict   = "RESTRICT"+    foreignKeyActionToSQL ForeignKeyCascade    = "CASCADE"+    foreignKeyActionToSQL ForeignKeySetNull    = "SET NULL"     foreignKeyActionToSQL ForeignKeySetDefault = "SET DEFAULT"  sqlDropFK :: RawSQL () -> ForeignKey -> RawSQL ()

@@ -1,21 +1,72 @@+{- |++Using migrations is fairly easy. After you've defined the lists of+migrations and tables, just run+'Database.PostgreSQL.PQTypes.Checks.migrateDatabase':++@+tables :: [Table]+tables = ...++migrations :: [Migration]+migrations = ...++migrateDatabase options extensions domains tables migrations+@++Migrations are run strictly in the order specified in the migrations+list, starting with the first migration for which the corresponding+table in the DB has the version number equal to the 'mgrFrom' field of+the migration.++-}+ module Database.PostgreSQL.PQTypes.Model.Migration (-    Migration(..)+    DropTableMode(..),+    MigrationAction(..),+    Migration(..),+    isStandardMigration, isDropTableMigration   )  where  import Data.Int  import Database.PostgreSQL.PQTypes.Model.Table+import Database.PostgreSQL.PQTypes.SQL.Raw --- | Migration object. Fields description:--- * mgrTable is the table you're migrating--- * mgrFrom is the version you're migrating from (you don't specify what---   version you migrate TO, because version is always increased by 1, so---   if mgrFrom is 2, that means that after that migration is run, table---   version will equal 3--- * mgrDo is actual body of a migration+-- | Migration action to run, either an arbitrary 'MonadDB' action, or+-- something more fine-grained.+data MigrationAction m = -data Migration m = Migration {-  mgrTable :: Table-, mgrFrom  :: Int32-, mgrDo    :: m ()-}+  -- | Standard migration, i.e. an arbitrary 'MonadDB' action.+  StandardMigration (m ())++  -- | Drop table migration. Parameter is the drop table mode+  -- (@RESTRICT@/@CASCADE@). The 'Migration' record holds the name of+  -- the table to drop.+  | DropTableMigration DropTableMode++-- | Migration object.+data Migration m =+  Migration {+  -- | The name of the table you're migrating.+  mgrTableName :: RawSQL ()+  -- | The version you're migrating *from* (you don't specify what+  -- version you migrate TO, because version is always increased by 1,+  -- so if 'mgrFrom' is 2, that means that after that migration is run,+  -- table version will equal 3+, mgrFrom   :: Int32+  -- | Migration action.+, mgrAction :: MigrationAction m+  }++isStandardMigration :: Migration m -> Bool+isStandardMigration Migration{..} =+  case mgrAction of+    StandardMigration _  -> True+    DropTableMigration _ -> False++isDropTableMigration :: Migration m -> Bool+isDropTableMigration Migration{..} =+  case mgrAction of+    StandardMigration _  -> False+    DropTableMigration _ -> True

@@ -20,7 +20,7 @@ pkOnColumn = Just . PrimaryKey . S.singleton  pkOnColumns :: [RawSQL ()] -> Maybe PrimaryKey-pkOnColumns [] = Nothing+pkOnColumns []      = Nothing pkOnColumns columns = Just . PrimaryKey . S.fromList $ columns  pkName :: RawSQL () -> RawSQL ()

@@ -10,6 +10,8 @@   , tblTable   , sqlCreateTable   , sqlAlterTable+  , DropTableMode(..)+  , sqlDropTable   , TableInitialSetup(..)   ) where @@ -60,15 +62,16 @@  data Rows = forall row. (Show row, ToRow row) => Rows [ByteString] [row] -data Table = Table {-  tblName          :: RawSQL ()-, tblVersion       :: Int32-, tblColumns       :: [TableColumn]-, tblPrimaryKey    :: Maybe PrimaryKey-, tblChecks        :: [Check]-, tblForeignKeys   :: [ForeignKey]-, tblIndexes       :: [TableIndex]-, tblInitialSetup  :: Maybe TableInitialSetup+data Table =+  Table {+  tblName         :: RawSQL () -- ^ Must be in lower case.+, tblVersion      :: Int32+, tblColumns      :: [TableColumn]+, tblPrimaryKey   :: Maybe PrimaryKey+, tblChecks       :: [Check]+, tblForeignKeys  :: [ForeignKey]+, tblIndexes      :: [TableIndex]+, tblInitialSetup :: Maybe TableInitialSetup }  data TableInitialSetup = TableInitialSetup {@@ -90,6 +93,19 @@  sqlCreateTable :: RawSQL () -> RawSQL () sqlCreateTable tname = "CREATE TABLE" <+> tname <+> "()"++-- | Whether to also drop objects that depend on the table.+data DropTableMode =+  -- | Automatically drop objects that depend on the table (such as views).+  DropTableCascade |+  -- | Refuse to drop the table if any objects depend on it. This is the default.+  DropTableRestrict++sqlDropTable :: RawSQL () -> DropTableMode -> RawSQL ()+sqlDropTable tname mode = "DROP TABLE" <+> tname+  <+> case mode of+        DropTableCascade  -> "CASCADE"+        DropTableRestrict -> "RESTRICT"  sqlAlterTable :: RawSQL () -> [RawSQL ()] -> RawSQL () sqlAlterTable tname alter_statements = smconcat [

@@ -1,22 +1,30 @@ {- | -Module SQL2 offers some nice monadic function that build SQL commands-on the fly. Some examples:+Module "Database.PostgreSQL.PQTypes.SQL.Builder" offers a nice+monadic DSL for building SQL statements on the fly. Some examples: -> kRun_ $ sqlSelect "documents" $ do->   sqlResult "id"->   sqlResult "title"->   sqlResult "mtime"->   sqlOrderBy "documents.mtime DESC"->   sqlWhereILike "documents.title" pattern+>>> :{+>>> | sqlSelect "documents" $ do+>>> |  sqlResult "id"+>>> |  sqlResult "title"+>>> |  sqlResult "mtime"+>>> |  sqlOrderBy "documents.mtime DESC"+>>> |  sqlWhereILike "documents.title" "%pattern%"+>>> :}+SQL " SELECT  id, title, mtime FROM documents WHERE (documents.title ILIKE <\"%pattern%\">)   ORDER BY documents.mtime DESC  " -SQL2 supports SELECT as 'sqlSelect' and data manipulation using+@SQL.Builder@ supports SELECT as 'sqlSelect' and data manipulation using 'sqlInsert', 'sqlInsertSelect', 'sqlDelete' and 'sqlUpdate'. -> kRun_ $ sqlInsert "documents" $ do->   sqlSet "title" title->   sqlSet "ctime" now->   sqlResult "id"+>>> import Data.Time.Clock+>>> now <- getCurrentTime+>>> :{+>>> | sqlInsert "documents" $ do+>>> |   sqlSet "title" title+>>> |   sqlSet "ctime" now+>>> |   sqlResult "id"+>>> :}+SQL " INSERT INTO documents (title, ctime) VALUES (<\"title\">, <\"2017-02-01 17:56:20.324894547 UTC\">) RETURNING id"  The 'sqlInsertSelect' is particulary interesting as it supports INSERT of values taken from a SELECT clause from same or even different@@ -29,58 +37,70 @@ lists will be made equal in length by appending @DEFAULT@ as fill element. -> kRun_ $ sqlInsert "documents" $ do->   sqlSet "ctime" now->   sqlSetList "title" [title1, title2, title3]->   sqlResult "id"+>>> :{+>>> | sqlInsert "documents" $ do+>>> |   sqlSet "ctime" now+>>> |   sqlSetList "title" ["title1", "title2", "title3"]+>>> |   sqlResult "id"+>>> :}+SQL " INSERT INTO documents (ctime, title) VALUES (<\"2017-02-01 17:56:20.324894547 UTC\">, <\"title1\">) , (<\"2017-02-01 17:56:20.324894547 UTC\">, <\"title2\">) , (<\"2017-02-01 17:56:20.324894547 UTC\">, <\"title3\">) RETURNING id"  The above will insert 3 new documents. -SQL2 provides quite a lot of SQL magic, including @ORDER BY@ as+@SQL.Builder@ provides quite a lot of SQL magic, including @ORDER BY@ as 'sqlOrderBy', @GROUP BY@ as 'sqlGroupBy'. -> kRun_ $ sqlSelect "documents" $ do->   sqlResult "id"->   sqlResult "title"->   sqlResult "mtime"->   sqlOrderBy "documents.mtime DESC"->   sqlOrderBy "documents.title"->   sqlGroupBy "documents.status"->   sqlJoinOn "users" "documents.user_id = users.id"->   sqlWhere $ SQL "documents.title ILIKE ?" [toSql pattern]+>>> :{+>>> | sqlSelect "documents" $ do+>>> |   sqlResult "id"+>>> |   sqlResult "title"+>>> |   sqlResult "mtime"+>>> |   sqlOrderBy "documents.mtime DESC"+>>> |   sqlOrderBy "documents.title"+>>> |   sqlGroupBy "documents.status"+>>> |   sqlJoinOn "users" "documents.user_id = users.id"+>>> |   sqlWhere $ mkSQL "documents.title ILIKE" <?> "%pattern%"+>>> :}+SQL " SELECT  id, title, mtime FROM documents  JOIN  users  ON  documents.user_id = users.id WHERE (documents.title ILIKE <\"%pattern%\">) GROUP BY documents.status  ORDER BY documents.mtime DESC, documents.title  "  Joins are done by 'sqlJoinOn', 'sqlLeftJoinOn', 'sqlRightJoinOn', 'sqlJoinOn', 'sqlFullJoinOn'. If everything fails use 'sqlJoin' and 'sqlFrom' to set join clause as string. Support for a join grammars as some kind of abstract syntax data type is lacking. -> kRun_ $ sqlDelete "mails" $ do->   sqlWhere "id > 67"+>>> :{+>>> | sqlDelete "mails" $ do+>>> |   sqlWhere "id > 67"+>>> :}+SQL " DELETE FROM mails  WHERE (id > 67) " -> kRun_ $ sqlUpdate "document_tags" $ do->   sqlSet "value" (123 :: Int)->   sqlWhere "name = 'abc'"+>>> :{+>>> | sqlUpdate "document_tags" $ do+>>> |   sqlSet "value" (123 :: Int)+>>> |   sqlWhere "name = 'abc'"+>>> :}+SQL " UPDATE document_tags SET value=<123>  WHERE (name = 'abc') "  Exception returning and 'kWhyNot' are a subsystem for querying why a query did not provide expected results. For example:  > let query = sqlUpdate "documents" $ do->               sqlSet "deleted" True->               sqlWhereEq "documents.id" 12345->               sqlWhereEqE DocumentDeleteFlagMustBe "documents.deleted" False->               sqlWhereILikeE DocumentTitleMustContain "documents.title" "%important%"+>   sqlSet "deleted" True+>   sqlWhereEq "documents.id" 12345+>   sqlWhereEqE DocumentDeleteFlagMustBe "documents.deleted" False+>   sqlWhereILikeE DocumentTitleMustContain "documents.title" "%important%" > result <- kRun query -In result is zero then no document was updated. We would like to know-what happened. In query we have three filtering clauses. One is a+If the result is zero then no document was updated. We would like to+know what happened. In query we have three filtering clauses. One is a baseline: the one mentioning @documents.id@. Baseline clauses define-what objects are we talking about. Other clauses are correctness+what objects we are talking about. Other clauses are correctness checks and may fail if status of on object is unexpected. Using 'kWhyNot' we can see what is wrong with an object:  > problems <- kWhyNot query -Now problems should contain a list of issues with rows that could be+Now @problems@ should contain a list of issues with rows that could be possibly be affected by weren't due to correctness clauses. For example it may state: @@ -98,6 +118,9 @@ fullfills all conditions at the same time although there are some that fullfill each one separatelly. +Note: @kWhyNot@ is currently disabled. Use 'kWhyNot1' instead, which+returns a single exception.+ -}  -- TODO: clean this up and fix the mess with@@ -222,6 +245,7 @@ import Data.Typeable import Database.PostgreSQL.PQTypes import Prelude+import Safe (atMay) import qualified Text.JSON.Gen as JSON  class Sqlable a where@@ -257,23 +281,25 @@ data Multiplicity a = Single a | Many [a]   deriving (Eq, Ord, Show, Typeable) --- | 'SqlCondition' are clauses that are in SQL statements in the--- WHERE block. Each statement has a list of conditions, all of them--- must be fullfilled.  Sometimes we need to inspect internal+-- | 'SqlCondition' are clauses that are part of the WHERE block in+-- SQL statements. Each statement has a list of conditions, all of+-- them must be fulfilled.  Sometimes we need to inspect internal -- structure of a condition. For now it seems that the only--- interesting case is EXISTS (SELECT ...) because that internal+-- interesting case is EXISTS (SELECT ...), because that internal -- SELECT can have explainable clauses. data SqlCondition = SqlPlainCondition SQL SqlWhyNot                   | SqlExistsCondition SqlSelect                     deriving (Typeable, Show) --- | 'SqlWhyNot' contains recepie how to query the database for--- current values in there and construct proper exception object using--- that information. For @SqlWhyNot mkException queries@ the--- @mkException@ should take as input same lenth list as there are--- queries. Each query will be run in a JOIN context with all--- referenced tables, so it can extract values from there.-data SqlWhyNot = forall e row. (FromRow row, DBExtraException e) => SqlWhyNot Bool (row -> e) [SQL]+-- | 'SqlWhyNot' contains a recipe for how to query the database for+-- some values we're interested in and construct a proper exception+-- object using that information. For @SqlWhyNot mkException queries@+-- the @mkException@ should take as input a list of the same length+-- list as there are queries. Each query will be run in a JOIN context+-- with all referenced tables, so it can extract values from there.+data SqlWhyNot =+  forall e row. (FromRow row, DBExtraException e) =>+  SqlWhyNot Bool (row -> e) [SQL]  {- instance Eq SqlCondition where@@ -290,55 +316,55 @@   toSQLCommand (SqlExistsCondition a) = "EXISTS (" <> toSQLCommand (a { sqlSelectResult = ["TRUE"] }) <> ")"  data SqlSelect = SqlSelect-  { sqlSelectFrom    :: SQL+  { sqlSelectFrom     :: SQL   , sqlSelectDistinct :: Bool-  , sqlSelectResult  :: [SQL]-  , sqlSelectWhere   :: [SqlCondition]-  , sqlSelectOrderBy :: [SQL]-  , sqlSelectGroupBy :: [SQL]-  , sqlSelectHaving  :: [SQL]-  , sqlSelectOffset  :: Integer-  , sqlSelectLimit   :: Integer-  , sqlSelectWith    :: [(SQL, SQL)]+  , sqlSelectResult   :: [SQL]+  , sqlSelectWhere    :: [SqlCondition]+  , sqlSelectOrderBy  :: [SQL]+  , sqlSelectGroupBy  :: [SQL]+  , sqlSelectHaving   :: [SQL]+  , sqlSelectOffset   :: Integer+  , sqlSelectLimit    :: Integer+  , sqlSelectWith     :: [(SQL, SQL)]   }  data SqlUpdate = SqlUpdate-  { sqlUpdateWhat    :: SQL-  , sqlUpdateFrom    :: SQL-  , sqlUpdateWhere   :: [SqlCondition]-  , sqlUpdateSet     :: [(SQL,SQL)]-  , sqlUpdateResult  :: [SQL]-  , sqlUpdateWith    :: [(SQL, SQL)]+  { sqlUpdateWhat   :: SQL+  , sqlUpdateFrom   :: SQL+  , sqlUpdateWhere  :: [SqlCondition]+  , sqlUpdateSet    :: [(SQL,SQL)]+  , sqlUpdateResult :: [SQL]+  , sqlUpdateWith   :: [(SQL, SQL)]   }  data SqlInsert = SqlInsert-  { sqlInsertWhat    :: SQL-  , sqlInsertSet     :: [(SQL, Multiplicity SQL)]-  , sqlInsertResult  :: [SQL]-  , sqlInsertWith    :: [(SQL, SQL)]+  { sqlInsertWhat   :: SQL+  , sqlInsertSet    :: [(SQL, Multiplicity SQL)]+  , sqlInsertResult :: [SQL]+  , sqlInsertWith   :: [(SQL, SQL)]   }  data SqlInsertSelect = SqlInsertSelect-  { sqlInsertSelectWhat    :: SQL+  { sqlInsertSelectWhat     :: SQL   , sqlInsertSelectDistinct :: Bool-  , sqlInsertSelectSet     :: [(SQL, SQL)]-  , sqlInsertSelectResult  :: [SQL]-  , sqlInsertSelectFrom    :: SQL-  , sqlInsertSelectWhere   :: [SqlCondition]-  , sqlInsertSelectOrderBy :: [SQL]-  , sqlInsertSelectGroupBy :: [SQL]-  , sqlInsertSelectHaving  :: [SQL]-  , sqlInsertSelectOffset  :: Integer-  , sqlInsertSelectLimit   :: Integer-  , sqlInsertSelectWith    :: [(SQL, SQL)]+  , sqlInsertSelectSet      :: [(SQL, SQL)]+  , sqlInsertSelectResult   :: [SQL]+  , sqlInsertSelectFrom     :: SQL+  , sqlInsertSelectWhere    :: [SqlCondition]+  , sqlInsertSelectOrderBy  :: [SQL]+  , sqlInsertSelectGroupBy  :: [SQL]+  , sqlInsertSelectHaving   :: [SQL]+  , sqlInsertSelectOffset   :: Integer+  , sqlInsertSelectLimit    :: Integer+  , sqlInsertSelectWith     :: [(SQL, SQL)]   }  data SqlDelete = SqlDelete-  { sqlDeleteFrom    :: SQL-  , sqlDeleteUsing   :: SQL-  , sqlDeleteWhere   :: [SqlCondition]-  , sqlDeleteResult  :: [SQL]-  , sqlDeleteWith    :: [(SQL, SQL)]+  { sqlDeleteFrom   :: SQL+  , sqlDeleteUsing  :: SQL+  , sqlDeleteWhere  :: [SqlCondition]+  , sqlDeleteResult :: [SQL]+  , sqlDeleteWith   :: [(SQL, SQL)]   }  -- | This is not exported and is used as an implementation detail in@@ -422,9 +448,9 @@       -- this is the longest list of values       longest = maximum (1 : (map (lengthOfEither . snd) (sqlInsertSet cmd)))       lengthOfEither (Single _) = 1-      lengthOfEither (Many x) = length x+      lengthOfEither (Many x)   = length x       makeLongEnough (Single x) = take longest (repeat x)-      makeLongEnough (Many x) = take longest (x ++ repeat "DEFAULT")+      makeLongEnough (Many x)   = take longest (x ++ repeat "DEFAULT")  instance Sqlable SqlInsertSelect where   toSQLCommand cmd =@@ -573,29 +599,47 @@           -> m () sqlIgnore clauses = modify (\cmd -> unSqlWhereIgnore (execState clauses (SqlWhereIgnore cmd))) +-- | The @WHERE@ part of an SQL query. See above for a usage+-- example. See also 'SqlCondition'. sqlWhere :: (MonadState v m, SqlWhere v) => SQL -> m () sqlWhere sql = sqlWhereE (DBBaseLineConditionIsFalse sql) sql +-- | Like 'sqlWhere', but also takes an exception value that is thrown+-- in case of error. See 'SqlCondition' and 'SqlWhyNot'. sqlWhereE :: (MonadState v m, SqlWhere v, DBExtraException e) => e -> SQL -> m () sqlWhereE exc sql = modify (\cmd -> sqlWhere1 cmd (SqlPlainCondition sql (SqlWhyNot True exc2 [])))   where     exc2 (_::()) = exc +-- | Like 'sqlWhereE', but takes a one-argument function that+-- constructs an exception value plus an SQL fragment for querying the+-- database for the argument that is fed into the exception+-- constructor function. See 'SqlCondition' and 'SqlWhyNot'.+--+-- The SQL fragment should be of form @TABLENAME.COLUMNAME@, as it is+-- executed as part of a @SELECT@ query involving all referenced+-- tables. sqlWhereEV :: (MonadState v m, SqlWhere v, DBExtraException e, FromSQL a) => (a -> e, SQL) -> SQL -> m () sqlWhereEV (exc, vsql) sql = modify (\cmd -> sqlWhere1 cmd (SqlPlainCondition sql (SqlWhyNot True exc2 [vsql])))   where     exc2 (Identity v1) = exc v1 +-- | Like 'sqlWhereEV', but the exception constructor function takes+-- two arguments. sqlWhereEVV :: (MonadState v m, SqlWhere v, DBExtraException e, FromSQL a, FromSQL b) => (a -> b -> e, SQL, SQL) -> SQL -> m () sqlWhereEVV (exc, vsql1, vsql2) sql = modify (\cmd -> sqlWhere1 cmd (SqlPlainCondition sql (SqlWhyNot True exc2 [vsql1, vsql2])))   where     exc2 (v1, v2) = exc v1 v2 +-- | Like 'sqlWhereEV', but the exception constructor function takes+-- three arguments. sqlWhereEVVV :: (MonadState v m, SqlWhere v, DBExtraException e, FromSQL a, FromSQL b, FromSQL c) => (a -> b -> c -> e, SQL, SQL, SQL) -> SQL -> m () sqlWhereEVVV (exc, vsql1, vsql2, vsql3) sql = modify (\cmd -> sqlWhere1 cmd (SqlPlainCondition sql (SqlWhyNot True exc2 [vsql1, vsql2, vsql3])))   where     exc2 (v1, v2, v3) = exc v1 v2 v3 +-- | Like 'sqlWhereEV', but the exception constructor function takes+-- four arguments. sqlWhereEVVVV :: (MonadState v m, SqlWhere v, DBExtraException e, FromSQL a, FromSQL b, FromSQL c, FromSQL d) => (a -> b -> c -> d -> e, SQL, SQL, SQL, SQL) -> SQL -> m () sqlWhereEVVVV (exc, vsql1, vsql2, vsql3, vsql4) sql = modify (\cmd -> sqlWhere1 cmd (SqlPlainCondition sql (SqlWhyNot True exc2 [vsql1, vsql2, vsql3, vsql4])))   where@@ -854,7 +898,7 @@   sqlTurnIntoSelect = id  --- | The 'sqlTurnIntoWhyNotSelect' turn a failed query into a+-- | The 'sqlTurnIntoWhyNotSelect' turns a failed query into a -- why-not-query that can explain why query altered zero rows or -- returned zero results. --@@ -871,7 +915,7 @@ -- >                                 FROM t3 -- >                                WHERE cond4)) ----- sqlTurnIntoWhyNotSelect will produce a SELECT of the form:+-- 'sqlTurnIntoWhyNotSelect' will produce a @SELECT@ of the form: -- -- > SELECT -- >   EXISTS (SELECT TRUE ... WHERE cond1),@@ -880,31 +924,31 @@ -- >   EXISTS (SELECT TRUE ... WHERE cond1 AND cond2 AND cond3 AND cond4); -- -- Now, after this statement is executed we see which of these--- returned FALSE as the first one. This is the condition that failed+-- returned @FALSE@ as the first one. This is the condition that failed -- the whole query. -- -- We can get more information at this point. If failed condition was--- cond2, then value2 can be extracted by this statement:+-- @cond2@, then @value2@ can be extracted by this statement: -- -- > SELECT value2 ... WHERE cond1; ----- If failed condition was cond3, then statement executed can be:+-- If failed condition was @cond3@, then statement executed can be: -- -- > SELECT value3a, value3b ... WHERE cond1 AND cond2; ----- Rationale: EXISTS clauses should pinpoint which condX was the first--- one to produce zero rows.  SELECT clauses after EXISTS should+-- Rationale: @EXISTS@ clauses should pinpoint which @condX@ was the first+-- one to produce zero rows.  @SELECT@ clauses after @EXISTS@ should -- explain why condX filtered out all rows. ----- 'DB.WhyNot.kWhyNot1' looks for first EXISTS clause that is FALSE--- and then tries to construct Exception object with values that come+-- 'DB.WhyNot.kWhyNot1' looks for first @EXISTS@ clause that is @FALSE@+-- and then tries to construct an @Exception@ object with values that come -- after. If values that comes after cannot be sensibly parsed--- (usually they are NULL when a value is expected), this exception is+-- (usually they are @NULL@ when a value is expected), this exception is -- skipped and next one is tried. ----- If first EXISTS clause is TRUE but no other exception was properly--- generated then DBExceptionCouldNotParseValues is thrown with pair--- of typeRef of first exception that could not be parsed and with+-- If first @EXISTS@ clause is @TRUE@ but no other exception was properly+-- generated then @DBExceptionCouldNotParseValues@ is thrown with pair+-- of 'typeRef' of first exception that could not be parsed and with -- list of SqlValues that it could not parse. -- -- The 'DB.WhyNot.kRun1OrThrowWhyNot' throws first exception on the@@ -1045,6 +1089,10 @@ -}  {-+-- | If 'kWhyNot1' returns an empty list of exceptions when none of+-- @EXISTS@ clauses generated by 'sqlTurnIntoWhyNotSelect' was+-- @FALSE@. Should not happen in real life, file a bug report if you see+-- such a case. kWhyNot :: (SqlTurnIntoSelect s, MonadDB m) => s -> m [[SomeDBExtraException]] kWhyNot cmd = do   let newSelect = sqlTurnIntoWhyNotSelect cmd@@ -1056,11 +1104,11 @@ -}  --- | DBExtraException and SomeDBExtraException mimic Exception and--- SomeException but we need our own class and data type to limit its+-- | 'DBExtraException' and 'SomeDBExtraException' mimic 'Exception' and+-- 'SomeException', but we need our own class and data type to limit its -- use to only those which describe semantic exceptions. ----- Our data types also feature conversion to json type so that+-- Our data types also feature conversion to JSON type so that -- external representation is known in place where exception is -- defined. class (Show e, Typeable e, JSON.ToJSValue e) => DBExtraException e where@@ -1093,19 +1141,19 @@   show (SomeDBExtraException e) = show e -} --- | Function kWhyNot1 is a workhorse for explainable SQL--- failures. SQL fails if it did not affect any rows or did no return--- any rows.  When that happens kWhyNot1 should be called. kWhyNot1--- returns a list of exceptions describing why a row could not be--- returned or affected by a query.------ If kWhyNot1 returns empty list of exception when none of EXISTS--- clauses generated by sqlTurnIntoWhyNotSelect was FALSE. Should not--- happen in real life, file a bug report if you see such a case.---- data ExceptionMaker = forall row. FromRow row => ExceptionMaker (row -> SomeDBExtraException) +data DBKwhyNotInternalError = DBKwhyNotInternalError String+  deriving (Show, Typeable)++instance DBExtraException DBKwhyNotInternalError++instance JSON.ToJSValue DBKwhyNotInternalError where+  toJSValue (DBKwhyNotInternalError msg) = JSON.runJSONGen $+    JSON.value "message"+    ("Internal error in Database.PostgreSQL.PQTypes.SQL.Builder.kWhyNot1Ex: "+     ++ msg)+ kWhyNot1Ex :: forall m s. (SqlTurnIntoSelect s, MonadDB m, MonadThrow m)            => s -> m (Bool, SomeDBExtraException) kWhyNot1Ex cmd = do@@ -1118,11 +1166,15 @@    let logics = enumerateWhyNotExceptions ((sqlSelectFrom newSelect),[]) (sqlGetWhereConditions newSelect) -  let condition = logics !! (indexOfFirstFailedCondition)+  let mcondition = logics `atMay` indexOfFirstFailedCondition -  case condition of-    (important, ExceptionMaker exception, _from, []) -> return (important, exception $ error "kWhyNot1Ex: this argument should've been ignored")-    (important, ExceptionMaker exception, (from, conds), sqls) -> do+  case mcondition of+    Nothing -> return+      (True, toDBExtraException . DBKwhyNotInternalError $+        "list of failed conditions is empty")+    Just (important, ExceptionMaker exception, _from, []) ->+      return (important, exception $ error "this argument should've been ignored")+    Just (important, ExceptionMaker exception, (from, conds), sqls) -> do        let statement' = sqlSelect2 from $ do              mapM_ sqlResult sqls              sqlLimit (1::Int)@@ -1133,6 +1185,11 @@        result <- fetchOne exception        return (important, result) +-- | Function 'kWhyNot1' is a workhorse for explainable SQL+-- failures. SQL fails if it did not affect any rows or did not return+-- any rows.  When that happens 'kWhyNot1' should be called. 'kWhyNot1'+-- returns an exception describing why a row could not be+-- returned or affected by a query. kWhyNot1 :: (SqlTurnIntoSelect s, MonadDB m, MonadThrow m)          => s -> m SomeDBExtraException kWhyNot1 cmd = snd `fmap` kWhyNot1Ex cmd

@@ -0,0 +1,737 @@+module Main+  where++import Control.Exception.Lifted as E+import Control.Monad.IO.Class++import Data.Monoid+import Data.Int+import qualified Data.Text as T+import Data.Typeable++import Database.PostgreSQL.PQTypes+import Database.PostgreSQL.PQTypes.Checks+import Database.PostgreSQL.PQTypes.Model.ColumnType+import Database.PostgreSQL.PQTypes.Model.ForeignKey+import Database.PostgreSQL.PQTypes.Model.Migration+import Database.PostgreSQL.PQTypes.Model.PrimaryKey+import Database.PostgreSQL.PQTypes.Model.Table+import Database.PostgreSQL.PQTypes.SQL.Builder+import Log+import Log.Backend.StandardOutput++import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.Options++data ConnectionString = ConnectionString String+  deriving Typeable++instance IsOption ConnectionString where+  defaultValue = ConnectionString+                 "postgresql://postgres@localhost/travis_ci_test"+  parseValue   = Just . ConnectionString+  optionName   = return "connection-string"+  optionHelp   = return "Postgres connection string"++-- Simple example schemata inspired by the one in+-- <http://www.databaseanswers.org/data_models/bank_robberies/index.htm>+--+-- Schema 1: Bank robberies, tables:+--           bank, bad_guy, robbery, participated_in_robbery, witness,+--           witnessed_robbery+-- Schema 2: Witnesses go into witness protection program,+--           (some) bad guys get arrested:+--           drop tables witness and witnessed_robbery,+--           add table under_arrest+-- Schema 3: Bad guys get their prison sentences:+--           drop table under_arrest+--           add table prison_sentence+-- Schema 4: New 'cash' column for the 'bank' table.+-- Schema 5: Create a new table 'flash',+--           drop the 'cash' column from the 'bank' table,+--           drop table 'flash'.+-- Cleanup:  drop everything++tableBankSchema1 :: Table+tableBankSchema1 =+  tblTable+  { tblName = "bank"+  , tblVersion = 1+  , tblColumns =+    [ tblColumn { colName = "id",       colType = BigSerialT+                , colNullable = False }+    , tblColumn { colName = "name",     colType = TextT+                , colNullable = False }+    , tblColumn { colName = "location", colType = TextT+                , colNullable = False }+    ]+  , tblPrimaryKey = pkOnColumn "id"+  }++tableBankSchema2 :: Table+tableBankSchema2 = tableBankSchema1++tableBankSchema3 :: Table+tableBankSchema3 = tableBankSchema2++tableBankMigration4 :: (MonadDB m) => Migration m+tableBankMigration4 = Migration+  { mgrTableName = tblName tableBankSchema3+  , mgrFrom      = 1+  , mgrAction    = StandardMigration $ do+      runQuery_ $ sqlAlterTable (tblName tableBankSchema3) [+        sqlAddColumn $ tblColumn+          { colName = "cash"+          , colType = IntegerT+          , colNullable = False+          , colDefault = Just "0"+          }+        ]+  }++tableBankSchema4 :: Table+tableBankSchema4 = tableBankSchema3 {+    tblVersion = (tblVersion tableBankSchema3)  + 1+  , tblColumns = (tblColumns tableBankSchema3) ++ [+      tblColumn+      { colName = "cash", colType = IntegerT+      , colNullable = False+      , colDefault = Just "0"+      }+    ]+  }+++tableBankMigration5 :: (MonadDB m) => Migration m+tableBankMigration5 = Migration+  { mgrTableName = tblName tableBankSchema3+  , mgrFrom      = 2+  , mgrAction    = StandardMigration $ do+      runQuery_ $ sqlAlterTable (tblName tableBankSchema4) [+        sqlDropColumn $ "cash"+        ]+  }+++tableBankSchema5 :: Table+tableBankSchema5 = tableBankSchema4 {+    tblVersion = (tblVersion tableBankSchema4)  + 1+  , tblColumns = filter (\c -> colName c /= "cash")+      (tblColumns tableBankSchema4)+  }++tableBadGuySchema1 :: Table+tableBadGuySchema1 =+  tblTable+  { tblName = "bad_guy"+  , tblVersion = 1+  , tblColumns =+    [ tblColumn { colName = "id",        colType = BigSerialT+                , colNullable = False }+    , tblColumn { colName = "firstname", colType = TextT+                , colNullable = False }+    , tblColumn { colName = "lastname",  colType = TextT+                , colNullable = False }+    ]+  , tblPrimaryKey = pkOnColumn "id" }++tableBadGuySchema2 :: Table+tableBadGuySchema2 = tableBadGuySchema1++tableBadGuySchema3 :: Table+tableBadGuySchema3 = tableBadGuySchema2++tableBadGuySchema4 :: Table+tableBadGuySchema4 = tableBadGuySchema3++tableBadGuySchema5 :: Table+tableBadGuySchema5 = tableBadGuySchema4++tableRobberySchema1 :: Table+tableRobberySchema1 =+  tblTable+  { tblName = "robbery"+  , tblVersion = 1+  , tblColumns =+    [ tblColumn { colName = "id",      colType = BigSerialT+                , colNullable = False }+    , tblColumn { colName = "bank_id", colType = BigIntT+                , colNullable = False }+    , tblColumn { colName = "date",    colType = DateT+                , colNullable = False, colDefault = Just "now()" }+    ]+  , tblPrimaryKey  = pkOnColumn "id"+  , tblForeignKeys = [fkOnColumn "bank_id" "bank" "id"] }++tableRobberySchema2 :: Table+tableRobberySchema2 = tableRobberySchema1++tableRobberySchema3 :: Table+tableRobberySchema3 = tableRobberySchema2++tableRobberySchema4 :: Table+tableRobberySchema4 = tableRobberySchema3++tableRobberySchema5 :: Table+tableRobberySchema5 = tableRobberySchema4++tableParticipatedInRobberySchema1 :: Table+tableParticipatedInRobberySchema1 =+  tblTable+  { tblName = "participated_in_robbery"+  , tblVersion = 1+  , tblColumns =+    [ tblColumn { colName = "bad_guy_id", colType = BigIntT+                , colNullable = False }+    , tblColumn { colName = "robbery_id", colType = BigIntT+                , colNullable = False }+    ]+  , tblPrimaryKey  = pkOnColumns ["bad_guy_id", "robbery_id"]+  , tblForeignKeys = [fkOnColumn  "bad_guy_id" "bad_guy" "id"+                     ,fkOnColumn  "robbery_id" "robbery" "id"] }++tableParticipatedInRobberySchema2 :: Table+tableParticipatedInRobberySchema2 = tableParticipatedInRobberySchema1++tableParticipatedInRobberySchema3 :: Table+tableParticipatedInRobberySchema3 = tableParticipatedInRobberySchema2++tableParticipatedInRobberySchema4 :: Table+tableParticipatedInRobberySchema4 = tableParticipatedInRobberySchema3++tableParticipatedInRobberySchema5 :: Table+tableParticipatedInRobberySchema5 = tableParticipatedInRobberySchema4++tableWitnessName :: RawSQL ()+tableWitnessName = "witness"++tableWitnessSchema1 :: Table+tableWitnessSchema1 =+  tblTable+  { tblName = tableWitnessName+  , tblVersion = 1+  , tblColumns =+    [ tblColumn { colName = "id",        colType = BigSerialT+                , colNullable = False }+    , tblColumn { colName = "firstname", colType = TextT+                , colNullable = False }+    , tblColumn { colName = "lastname",  colType = TextT+                , colNullable = False }+    ]+  , tblPrimaryKey = pkOnColumn "id" }++tableWitnessedRobberyName :: RawSQL ()+tableWitnessedRobberyName = "witnessed_robbery"++tableWitnessedRobberySchema1 :: Table+tableWitnessedRobberySchema1 =+  tblTable+  { tblName = tableWitnessedRobberyName+  , tblVersion = 1+  , tblColumns =+    [ tblColumn { colName = "witness_id", colType = BigIntT+                , colNullable = False }+    , tblColumn { colName = "robbery_id", colType = BigIntT+                , colNullable = False }+    ]+  , tblPrimaryKey  = pkOnColumns ["witness_id", "robbery_id"]+  , tblForeignKeys = [fkOnColumn  "witness_id" "witness" "id"+                     ,fkOnColumn  "robbery_id" "robbery" "id"] }++tableUnderArrestName :: RawSQL ()+tableUnderArrestName = "under_arrest"++tableUnderArrestSchema2 :: Table+tableUnderArrestSchema2 =+  tblTable+  { tblName = tableUnderArrestName+  , tblVersion = 1+  , tblColumns =+    [ tblColumn { colName = "bad_guy_id", colType = BigIntT+                , colNullable = False }+    , tblColumn { colName = "robbery_id", colType = BigIntT+                , colNullable = False }+    , tblColumn { colName = "court_date", colType = DateT+                , colNullable = False+                , colDefault  = Just "now()" }+    ]+  , tblPrimaryKey  = pkOnColumns ["bad_guy_id", "robbery_id"]+  , tblForeignKeys = [fkOnColumn  "bad_guy_id" "bad_guy" "id"+                     ,fkOnColumn  "robbery_id" "robbery" "id"] }++tablePrisonSentenceName :: RawSQL ()+tablePrisonSentenceName = "prison_sentence"++tablePrisonSentenceSchema3 :: Table+tablePrisonSentenceSchema3 =+  tblTable+  { tblName = tablePrisonSentenceName+  , tblVersion = 1+  , tblColumns =+    [ tblColumn { colName = "bad_guy_id", colType = BigIntT+                , colNullable = False }+    , tblColumn { colName = "robbery_id", colType = BigIntT+                , colNullable = False }+    , tblColumn { colName = "sentence_start"+                , colType = DateT+                , colNullable = False+                , colDefault  = Just "now()" }+    , tblColumn { colName = "sentence_length"+                , colType = IntegerT+                , colNullable = False+                , colDefault  = Just "6" }+    , tblColumn { colName = "prison_name"+                , colType = TextT+                , colNullable = False }+    ]+  , tblPrimaryKey  = pkOnColumns ["bad_guy_id", "robbery_id"]+  , tblForeignKeys = [fkOnColumn  "bad_guy_id" "bad_guy" "id"+                     ,fkOnColumn  "robbery_id" "robbery" "id"] }++tablePrisonSentenceSchema4 :: Table+tablePrisonSentenceSchema4 = tablePrisonSentenceSchema3++tablePrisonSentenceSchema5 :: Table+tablePrisonSentenceSchema5 = tablePrisonSentenceSchema4++tableFlashName :: RawSQL ()+tableFlashName = "flash"++tableFlash :: Table+tableFlash =+  tblTable+  { tblName = tableFlashName+  , tblVersion = 1+  , tblColumns =+    [ tblColumn { colName = "flash_id", colType = BigIntT, colNullable = False }+    ]+  }++createTableMigration :: (MonadDB m) => Table -> Migration m+createTableMigration tbl = Migration+  { mgrTableName = tblName tbl+  , mgrFrom      = 0+  , mgrAction    = StandardMigration $ do+      createTable True tbl+  }++dropTableMigration :: (MonadDB m) => Table -> Migration m+dropTableMigration tbl = Migration+  { mgrTableName = tblName tbl+  , mgrFrom      = tblVersion tbl+  , mgrAction    = DropTableMigration DropTableCascade+  }++schema1Tables :: [Table]+schema1Tables = [ tableBankSchema1+                , tableBadGuySchema1+                , tableRobberySchema1+                , tableParticipatedInRobberySchema1+                , tableWitnessSchema1+                , tableWitnessedRobberySchema1+                ]++schema1Migrations :: (MonadDB m) => [Migration m]+schema1Migrations =+  [ createTableMigration tableBankSchema1+  , createTableMigration tableBadGuySchema1+  , createTableMigration tableRobberySchema1+  , createTableMigration tableParticipatedInRobberySchema1+  , createTableMigration tableWitnessSchema1+  , createTableMigration tableWitnessedRobberySchema1+  ]++schema2Tables :: [Table]+schema2Tables = [ tableBankSchema2+                , tableBadGuySchema2+                , tableRobberySchema2+                , tableParticipatedInRobberySchema2+                , tableUnderArrestSchema2+                ]++schema2Migrations :: (MonadDB m) => [Migration m]+schema2Migrations = schema1Migrations+                 ++ [ dropTableMigration   tableWitnessedRobberySchema1+                    , dropTableMigration   tableWitnessSchema1+                    , createTableMigration tableUnderArrestSchema2 ]++schema3Tables :: [Table]+schema3Tables = [ tableBankSchema3+                , tableBadGuySchema3+                , tableRobberySchema3+                , tableParticipatedInRobberySchema3+                , tablePrisonSentenceSchema3+                ]++schema3Migrations :: (MonadDB m) => [Migration m]+schema3Migrations = schema2Migrations+                 ++ [ dropTableMigration   tableUnderArrestSchema2+                    , createTableMigration tablePrisonSentenceSchema3 ]++schema4Tables :: [Table]+schema4Tables = [ tableBankSchema4+                , tableBadGuySchema4+                , tableRobberySchema4+                , tableParticipatedInRobberySchema4+                , tablePrisonSentenceSchema4+                ]++schema4Migrations :: (MonadDB m) => [Migration m]+schema4Migrations = schema3Migrations+                 ++ [ tableBankMigration4 ]++schema5Tables :: [Table]+schema5Tables = [ tableBankSchema5+                , tableBadGuySchema5+                , tableRobberySchema5+                , tableParticipatedInRobberySchema5+                , tablePrisonSentenceSchema5+                ]++schema5Migrations :: (MonadDB m) => [Migration m]+schema5Migrations = schema4Migrations+                 ++ [ createTableMigration tableFlash+                    , tableBankMigration5+                    , dropTableMigration tableFlash+                    ]++type TestM a = DBT (LogT IO) a++createTablesSchema1 :: (String -> TestM ()) -> TestM ()+createTablesSchema1 step = do+  step "Creating the database (schema version 1)..."+  migrateDatabase {- options -} [] {- extensions -} [] {- domains -} []+    schema1Tables schema1Migrations+  checkDatabase {- domains -} [] schema1Tables++testDBSchema1 :: (String -> TestM ()) -> TestM ([Int64], [Int64])+testDBSchema1 step = do+  step "Running test queries (schema version 1)..."++  -- Populate the 'bank' table.+  runQuery_ . sqlInsert "bank" $ do+    sqlSetList "name" ["HSBC" :: T.Text, "Swedbank", "Nordea", "Citi"+                      ,"Wells Fargo"]+    sqlSetList "location" ["13 Foo St., Tucson, AZ, USa" :: T.Text+                          , "18 Bargatan, Stockholm, Sweden"+                          , "23 Baz Lane, Liverpool, UK"+                          , "2/3 Quux Ave., Milton Keynes, UK"+                          , "6600 Sunset Blvd., Los Angeles, CA, USA"]+    sqlResult "id"+  (bankIds :: [Int64]) <- fetchMany runIdentity+  liftIO $ assertEqual "INSERT into 'bank' table" 5 (length bankIds)++  -- Populate the 'bad_guy' table.+  runQuery_ . sqlInsert "bad_guy" $ do+    sqlSetList "firstname" ["Neil" :: T.Text, "Lee", "Freddie", "Frankie"+                           ,"James", "Roy"]+    sqlSetList "lastname" ["Hetzel"::T.Text, "Murray", "Foreman", "Fraser"+                          ,"Crosbie", "Shaw"]+    sqlResult "id"+  (badGuyIds :: [Int64]) <- fetchMany runIdentity+  liftIO $ assertEqual "INSERT into 'bad_guy' table" 6 (length badGuyIds)++  -- Populate the 'robbery' table.+  runQuery_ . sqlInsert "robbery" $ do+    sqlSetList "bank_id" [bankIds !! idx | idx <- [0,3]]+    sqlResult "id"+  (robberyIds :: [Int64]) <- fetchMany runIdentity+  liftIO $ assertEqual "INSERT into 'robbery' table" 2 (length robberyIds)++  -- Populate the 'participated_in_robbery' table.+  runQuery_ . sqlInsert "participated_in_robbery" $ do+    sqlSetList "bad_guy_id" [badGuyIds  !! idx | idx <- [0,2]]+    sqlSet "robbery_id" (robberyIds !! 0)+    sqlResult "bad_guy_id"+  (participatorIds :: [Int64]) <- fetchMany runIdentity+  liftIO $ assertEqual "INSERT into 'participated_in_robbery' table" 2+    (length participatorIds)++  runQuery_ . sqlInsert "participated_in_robbery" $ do+    sqlSetList "bad_guy_id" [badGuyIds  !! idx | idx <- [3,4]]+    sqlSet "robbery_id" (robberyIds !! 1)+    sqlResult "bad_guy_id"+  (participatorIds' :: [Int64]) <- fetchMany runIdentity+  liftIO $ assertEqual "INSERT into 'participated_in_robbery' table" 2+    (length participatorIds')++  -- Populate the 'witness' table.+  runQuery_ . sqlInsert "witness" $ do+    sqlSetList "firstname" ["Meredith" :: T.Text, "Charlie", "Peter", "Emun"+                           ,"Benedict"]+    sqlSetList "lastname" ["Vickers"::T.Text, "Holloway", "Weyland", "Eliott"+                          ,"Wong"]+    sqlResult "id"+  (witnessIds :: [Int64]) <- fetchMany runIdentity+  liftIO $ assertEqual "INSERT into 'witness' table" 5 (length witnessIds)++  -- Populate the 'witnessed_robbery' table.+  runQuery_ . sqlInsert "witnessed_robbery" $ do+    sqlSetList "witness_id" [witnessIds  !! idx | idx <- [0,1]]+    sqlSet "robbery_id" (robberyIds !! 0)+    sqlResult "witness_id"+  (robberyWitnessIds :: [Int64]) <- fetchMany runIdentity+  liftIO $ assertEqual "INSERT into 'witnessed_robbery' table" 2+    (length robberyWitnessIds)++  runQuery_ . sqlInsert "witnessed_robbery" $ do+    sqlSetList "witness_id" [witnessIds  !! idx | idx <- [2,3,4]]+    sqlSet "robbery_id" (robberyIds !! 1)+    sqlResult "witness_id"+  (robberyWitnessIds' :: [Int64]) <- fetchMany runIdentity+  liftIO $ assertEqual "INSERT into 'witnessed_robbery' table" 3+    (length robberyWitnessIds')++  return (badGuyIds, robberyIds)++migrateDBToSchema2 :: (String -> TestM ()) -> TestM ()+migrateDBToSchema2 step = do+  step "Migrating the database (schema version 1 -> schema version 2)..."+  migrateDatabase {- options -} [] {- extensions -} [] {- domains -} []+    schema2Tables schema2Migrations+  checkDatabase {- domains -} [] schema2Tables++testDBSchema2 :: (String -> TestM ()) -> [Int64] -> [Int64] -> TestM ()+testDBSchema2 step badGuyIds robberyIds = do+  step "Running test queries (schema version 2)..."++  -- Check that table 'witness' doesn't exist.+  runSQL_ $ "SELECT EXISTS (SELECT 1 FROM pg_tables WHERE schemaname = 'public'"+    <> " AND tablename = 'witness')";+  (witnessExists :: Bool) <- fetchOne runIdentity+  liftIO $ assertEqual "Table 'witness' doesn't exist" False witnessExists++  -- Check that table 'witnessed_robbery' doesn't exist.+  runSQL_ $ "SELECT EXISTS (SELECT 1 FROM pg_tables WHERE schemaname = 'public'"+    <> " AND tablename = 'witnessed_robbery')";+  (witnessedRobberyExists :: Bool) <- fetchOne runIdentity+  liftIO $ assertEqual "Table 'witnessed_robbery' doesn't exist" False+    witnessedRobberyExists++  -- Populate table 'under_arrest'.+  runQuery_ . sqlInsert "under_arrest" $ do+    sqlSetList "bad_guy_id" [badGuyIds  !! idx | idx <- [0,2]]+    sqlSet "robbery_id" (robberyIds !! 0)+    sqlResult "bad_guy_id"+  (arrestedIds :: [Int64]) <- fetchMany runIdentity+  liftIO $ assertEqual "INSERT into 'under_arrest' table" 2+    (length arrestedIds)++  runQuery_ . sqlInsert "under_arrest" $ do+    sqlSetList "bad_guy_id" [badGuyIds  !! idx | idx <- [3,4]]+    sqlSet "robbery_id" (robberyIds !! 1)+    sqlResult "bad_guy_id"+  (arrestedIds' :: [Int64]) <- fetchMany runIdentity+  liftIO $ assertEqual "INSERT into 'under_arrest' table" 2+    (length arrestedIds')++  return ()++migrateDBToSchema3 :: (String -> TestM ()) -> TestM ()+migrateDBToSchema3 step = do+  step "Migrating the database (schema version 2 -> schema version 3)..."+  migrateDatabase {- options -} [] {- extensions -} [] {- domains -} []+    schema3Tables schema3Migrations+  checkDatabase {- domains -} [] schema3Tables++testDBSchema3 :: (String -> TestM ()) -> [Int64] -> [Int64] -> TestM ()+testDBSchema3 step badGuyIds robberyIds = do+  step "Running test queries (schema version 3)..."++  -- Check that table 'under_arrest' doesn't exist.+  runSQL_ $ "SELECT EXISTS (SELECT 1 FROM pg_tables WHERE schemaname = 'public'"+    <> " AND tablename = 'under_arrest')";+  (underArrestExists :: Bool) <- fetchOne runIdentity+  liftIO $ assertEqual "Table 'under_arrest' doesn't exist" False+    underArrestExists++  -- Check that the table 'prison_sentence' exists.+  runSQL_ $ "SELECT EXISTS (SELECT 1 FROM pg_tables WHERE schemaname = 'public'"+    <> " AND tablename = 'prison_sentence')";+  (prisonSentenceExists :: Bool) <- fetchOne runIdentity+  liftIO $ assertEqual "Table 'prison_sentence' does exist" True+    prisonSentenceExists++  -- Populate table 'prison_sentence'.+  runQuery_ . sqlInsert "prison_sentence" $ do+    sqlSetList "bad_guy_id" [badGuyIds  !! idx | idx <- [0,2]]+    sqlSet "robbery_id" (robberyIds !! 0)+    sqlSet "sentence_length" (12::Int)+    sqlSet "prison_name" ("Long Kesh"::T.Text)+    sqlResult "bad_guy_id"+  (sentencedIds :: [Int64]) <- fetchMany runIdentity+  liftIO $ assertEqual "INSERT into 'prison_sentence' table" 2+    (length sentencedIds)++  runQuery_ . sqlInsert "prison_sentence" $ do+    sqlSetList "bad_guy_id" [badGuyIds  !! idx | idx <- [3,4]]+    sqlSet "robbery_id" (robberyIds !! 1)+    sqlSet "sentence_length" (9::Int)+    sqlSet "prison_name" ("Wormwood Scrubs"::T.Text)+    sqlResult "bad_guy_id"+  (sentencedIds' :: [Int64]) <- fetchMany runIdentity+  liftIO $ assertEqual "INSERT into 'prison_sentence' table" 2+    (length sentencedIds')++  return ()++migrateDBToSchema4 :: (String -> TestM ()) -> TestM ()+migrateDBToSchema4 step = do+  step "Migrating the database (schema version 3 -> schema version 4)..."+  migrateDatabase {- options -} [] {- extensions -} [] {- domains -} []+    schema4Tables schema4Migrations+  checkDatabase {- domains -} [] schema4Tables++testDBSchema4 :: (String -> TestM ()) -> TestM ()+testDBSchema4 step = do+  step "Running test queries (schema version 4)..."++  -- Check that the 'bank' table has a 'cash' column.+  runSQL_ $ "SELECT EXISTS (SELECT 1 FROM information_schema.columns"+    <> " WHERE table_schema = 'public'"+    <> " AND table_name = 'bank'"+    <> " AND column_name = 'cash')";+  (colCashExists :: Bool) <- fetchOne runIdentity+  liftIO $ assertEqual "Column 'cash' in the table 'bank' does exist" True+    colCashExists++  return ()++migrateDBToSchema5 :: (String -> TestM ()) -> TestM ()+migrateDBToSchema5 step = do+  step "Migrating the database (schema version 4 -> schema version 5)..."+  migrateDatabase {- options -} [] {- extensions -} [] {- domains -} []+    schema5Tables schema5Migrations+  checkDatabase {- domains -} [] schema5Tables++testDBSchema5 :: (String -> TestM ()) -> TestM ()+testDBSchema5 step = do+  step "Running test queries (schema version 5)..."++  -- Check that the 'bank' table doesn't have a 'cash' column.+  runSQL_ $ "SELECT EXISTS (SELECT 1 FROM information_schema.columns"+    <> " WHERE table_schema = 'public'"+    <> " AND table_name = 'bank'"+    <> " AND column_name = 'cash')";+  (colCashExists :: Bool) <- fetchOne runIdentity+  liftIO $ assertEqual "Column 'cash' in the table 'bank' doesn't exist" False+    colCashExists++  -- Check that the 'flash' table doesn't exist.+  runSQL_ $ "SELECT EXISTS (SELECT 1 FROM pg_tables WHERE schemaname = 'public'"+    <> " AND tablename = 'flash')";+  (flashExists :: Bool) <- fetchOne runIdentity+  liftIO $ assertEqual "Table 'flash' doesn't exist" False flashExists++  return ()++-- | May require 'ALTER SCHEMA public OWNER TO $user' the first time+-- you run this.+freshTestDB ::  (String -> TestM ()) -> TestM ()+freshTestDB step = do+  step "Dropping the test DB schema..."+  runSQL_ "DROP SCHEMA public CASCADE"+  runSQL_ "CREATE SCHEMA public"++migrationTest1 :: ConnectionSourceM (LogT IO) -> TestTree+migrationTest1 connSource =+  testCaseSteps' "Migration test 1" connSource $ \step -> do+  freshTestDB         step++  createTablesSchema1 step+  (badGuyIds, robberyIds) <-+    testDBSchema1     step++  migrateDBToSchema2  step+  testDBSchema2       step badGuyIds robberyIds++  migrateDBToSchema3  step+  testDBSchema3       step badGuyIds robberyIds++  migrateDBToSchema4  step+  testDBSchema4       step++  migrateDBToSchema5  step+  testDBSchema5       step++  freshTestDB         step++-- | Test for behaviour of 'checkDatabase' and 'checkDatabaseAllowUnknownTables'+migrationTest2 :: ConnectionSourceM (LogT IO) -> TestTree+migrationTest2 connSource =+  testCaseSteps' "Migration test 2" connSource $ \step -> do+  freshTestDB         step++  createTablesSchema1 step+  let currentSchema = schema1Tables+      differentSchema = schema5Tables++  assertNoException "checkDatabase should run fine for consistent DB" $+    (checkDatabase [] currentSchema)+  assertNoException "checkDatabaseAllowUnknownTables runs fine for consistent DB" $+    (checkDatabaseAllowUnknownTables [] currentSchema)+  assertException "checkDatabase should throw exception for wrong scheme" $+    (checkDatabase [] differentSchema)+  assertException "checkDatabaseAllowUnknownTables should throw exception for wrong scheme" $+    (checkDatabaseAllowUnknownTables [] differentSchema)++  runSQL_ "INSERT INTO table_versions (name, version) VALUES ('unknown_table', 0)"+  assertException "checkDatabase throw when extra entry in 'table_versions'" $+    (checkDatabase [] currentSchema)+  assertNoException "checkDatabaseAllowUnknownTables accepts extra entry in 'table_versions'" $+    (checkDatabaseAllowUnknownTables [] currentSchema)+  runSQL_ "DELETE FROM table_versions where name='unknown_table'"++  runSQL_ "CREATE TABLE unknown_table (title text)"+  assertException "checkDatabase should throw with unknown table" $+    (checkDatabase [] currentSchema)+  assertNoException "checkDatabaseAllowUnknownTables accepts unknown table" $+    (checkDatabaseAllowUnknownTables [] currentSchema)++  runSQL_ "INSERT INTO table_versions (name, version) VALUES ('unknown_table', 0)"+  assertException "checkDatabase should throw with unknown table" $+    (checkDatabase [] currentSchema)+  assertNoException "checkDatabaseAllowUnknownTables accepts unknown tables with version" $+    (checkDatabaseAllowUnknownTables [] currentSchema)++  freshTestDB         step++  where+    assertNoException :: String -> TestM () -> TestM ()+    assertNoException t c = (E.try c) >>= \r -> case r of+      Left (_ :: SomeException) ->+        liftIO $ assertFailure ("Exception thrown for: " ++ t)+      Right _ -> return ()+    assertException :: String -> TestM () -> TestM ()+    assertException t c = (E.try c) >>= \r -> case r of+      Left (_ :: SomeException) -> return ()+      Right _ ->+        liftIO $ assertFailure ("No exception thrown for: " ++ t)++-- | A variant of testCaseSteps that works in TestM monad.+testCaseSteps' :: TestName -> ConnectionSourceM (LogT IO)+                -> ((String -> TestM ()) -> TestM ())+                -> TestTree+testCaseSteps' testName connSource f =+  testCaseSteps testName $ \step' -> do+  let step s = liftIO $ step' s+  withSimpleStdOutLogger $ \logger ->+    runLogT "hpqtypes-extras-test" logger $+    runDBT connSource {- transactionSettings -} def $+    f step++main :: IO ()+main = do+  defaultMainWithIngredients ings $+    askOption $ \(ConnectionString connectionString) ->+    let connSettings = def { csConnInfo = T.pack connectionString }+        ConnectionSource connSource = simpleSource connSettings+    in+    testGroup "DB tests" [ migrationTest1 connSource+                         , migrationTest2 connSource+                         ]+  where+    ings =+      includingOptions [Option (Proxy :: Proxy ConnectionString)]+      : defaultIngredients