diff --git a/Changelog.markdown b/Changelog.markdown new file mode 100644 --- /dev/null +++ b/Changelog.markdown @@ -0,0 +1,68 @@ +# Changelog + +## 0.2.1.0 + * Forked & renamed to postgresql-migration + * Support for changing the schema_migration table name + * Support custom logging + * API option to control how transactions are used + * Support for older GHC versions dropped + +## 0.1.15.0 +* Bumped dependencies + +## 0.1.14.0 +* Bumped dependencies + +## 0.1.13.1 +* Bumped dependencies + +## 0.1.13.0 +* Bumped dependencies + +## 0.1.12.0 +* Support for GHC 8.4 + +## 0.1.11.0 +* Improved documentation +* Fixed exists_table + +## 0.1.10.1 +* Fixed hackage warnings + +## 0.1.10.0 +* Relaxed time bounds + +## 0.1.9.0 +* Bumped dependencies + +## 0.1.8.0 +* Added MigrationCommands allowing sequencing of migrations in the Haskell API +* Derived more datatypes for MigrationResult +* Bumped dependencies + +## 0.1.7.0 +* Propagate migration and validation result to application exit code + +## 0.1.6.0 +* Support for GHC 8 + +## 0.1.5.0 +* Bumped dependencies + +## 0.1.4.0 +* Improved error logging in standalone binary + +## 0.1.3.0 +* Better transaction handling +* Improved documentation + +## 0.1.2.0 +* Moved Util module +* Improved documentation + +## 0.1.1.0 +* Support for schema validations. +* Improved Haskell API + +## 0.1.0.0 +* Support for file-based and Haskell migrations. diff --git a/License b/License new file mode 100644 --- /dev/null +++ b/License @@ -0,0 +1,30 @@ +Copyright (c) 2014, Andreas Meingast + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS +OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/Readme.markdown b/Readme.markdown new file mode 100644 --- /dev/null +++ b/Readme.markdown @@ -0,0 +1,236 @@ +# PostgreSQL Migrations for Haskell + +Forked from [postgresql-simple-migration](https://github.com/ameingast/postgresql-simple-migration) created by [Andreas Meingast](https://github.com/ameingast/postgresql-simple-migration) + +[![Haskell-CI](https://github.com/andrevdm/postgresql-simple-migration/actions/workflows/haskell-ci.yml/badge.svg?branch=master)](https://github.com/andrevdm/postgresql-simple-migration/actions/workflows/haskell-ci.yml) + + +Welcome to postgresql-migrations, a tool for helping you with +PostgreSQL schema migrations. + +This project is an open-source database migration tool. It favors simplicity +over configuration. + +It is implemented in Haskell and uses the (excellent) postgresql-simple +library to communicate with PostgreSQL. + +It comes in two flavors: a library that features an easy to use Haskell +API and as a standalone application. + +Database migrations can be written in SQL (in this case PostgreSQL-sql) +or in Haskell. + +## Why? +Database migrations should not be hard. They should be under version control +and documented both in your production systems and in your project files. + +## What? +This library executes SQL/Haskell migration scripts and keeps track of their +meta information. + +Scripts are be executed exactly once and any changes to scripts will cause +a run-time error notifying you of a corrupted database. + +The meta information consists of: +* an MD5 checksum of the executed script to make sure already existing + scripts cannot be modified in your production system. +* a time-stamp of the date of execution so you can easily track when a change + happened. + +This library also supports migration validation so you can ensure (some) +correctness before your application logic kicks in. + +## How? +This utility can be used in two ways: embedded in your Haskell program or as +a standalone binary. + +### Standalone +The standalone program supports file-based migrations. To execute all SQL-files +in a directory $BASE\_DIR, execute the following command to initialize the database +in a first step. + +```bash +CON="host=$host dbname=$db user=$user password=$pw" +cabal run migrate -- init $CON +cabal run migrate -- migrate $CON $BASE_DIR +``` + +To validate already executed scripts, execute the following: +```bash +CON="host=$host dbname=$db user=$user password=$pw" +cabal run migrate -- init $CON +cabal run migrate -- validate $CON $BASE_DIR +``` + +For more information about the PostgreSQL connection string, see: +[libpq-connect](http://www.postgresql.org/docs/9.3/static/libpq-connect.html). + +### Library +The library supports more actions than the standalone program. + +Initializing the database: + +```haskell +main :: IO () +main = do + let url = "host=$host dbname=$db user=$user password=$pw" + con <- connectPostgreSQL (BS8.pack url) + runMigration con defaultOptions MigrationInitialization +``` + +For file-based migrations, the following snippet can be used: + +```haskell +main :: IO () +main = do + let url = "host=$host dbname=$db user=$user password=$pw" + let dir = "." + con <- connectPostgreSQL (BS8.pack url) + runMigration con defaltOptions $ MigrationDirectory dir +``` + +To run Haskell-based migrations, use this: + +```haskell +main :: IO () +main = do + let url = "host=$host dbname=$db user=$user password=$pw" + let name = "my script" + let script = "create table users (email varchar not null)"; + con <- connectPostgreSQL (BS8.pack url) + runMigration con defaultOptions $ MigrationScript name script +``` + +Validations wrap _MigrationCommands_. This means that you can re-use all +MigrationCommands to perform a read-only validation of your migrations. + +To perform a validation on a directory-based migration, you can use the +following code: + +```haskell +main :: IO () +main = do + let url = "host=$host dbname=$db user=$user password=$pw" + con <- connectPostgreSQL (BS8.pack url) + runMigration con default Options $ MigrationValidation (MigrationDirectory dir) +``` + +### Transactions + +Database migrations should always be performed in a transactional context. + +The standalone binary and the API default to using a new transaction for the +entire set of migrations. + +Using the `-t` argument to the binary will change this to using a new transaction +per migration step (script). + +When using the library you have full control over the behaviour of transactions +by setting `optTransactionControl` on the `MigrationOptions` record. + +There are three options + + 1) No new transaction: you manage the transaction, e.g. if you want to run multiple migrations in a single transaction + 2) Transaction per run: This is the default. New transaction for the entire migration + 3) Transaction per step + +The tests make use `TransactionPerRun`, after executing all migration-tests, the +transaction is rolled back. + + +### Options + +The `runMigration` and `runMigration` functions take an options record that let you +set the following + + - `optVerbose`: Is verbose logging enabled or not + - `optLogWriter`: The function used to write log messages. Defaults to `stdout` for info and `stderr` for errors + - `optTableName`: The name for the migrations table. This defaults to `schema_migrations`. + - `optTransactionControl`: How transactions should be hanbled + + +## Compilation and Tests +The program can be built with _cabal_ or _stack_ build systems. + +The following command builds the library, the standalone binary and the test package with _cabal_ + +```bash +cabal configure --enable-tests && cabal build -j +``` + +To execute the tests, you need a running PostgreSQL server with an empty +database called _test_. Tests are executed through cabal as follows: + +```bash +cabal configure --enable-tests && cabal test +``` + +To build with stack use the following command + +```bash +stack build +``` + +To run the tests with stack use the following command + +```bash +stack test +``` + + +# Changes from the original postgresql-simple-migration (version 0.1) + +**postgresql-migration** is fork of *postgresql-simple-migration* created when the original *postgresql-simple-migration* project was archived. + +**postgresql-migration** version 0.2.x introduces some new features that will require some minor changes if you were using a 0.1.x version before + +The new features are + + - Support for custom logging (original PR from https://github.com/ameingast/postgresql-simple-migration/pull/36. Thanks @unclechu) + - Custom migrations table name (original PR from https://github.com/ameingast/postgresql-simple-migration/pull/30) + - Transaction control from the API (original request from https://github.com/ameingast/postgresql-simple-migration/issues/40) + + +There are two ways to move to **postgresql-migration** + + +## Compatability layer - the simple way, but no new features + + 1) Replace `postgresql-simple-migration` with `postgresql-migration` in your .cabal file + 2) Import `Database.PostgreSQL.Simple.Migration.V1Compat` rather than `Database.PostgreSQL.Simple.Migration` + +All your existing code should work as is + + +## Porting to version 2 + +The most obvious code change is that you now use a `MigrationOptions` rather than a `MigrationContext`. + + +_Version 0.1.x_ + +This what you would have had + +```haskell + withTransaction con . runMigration $ MigrationContext Pgm.MigrationInitialization True con +``` + + +_Version 0.2.x_ + +Version 2 with the defaultOptions + +```haskell + runMigration con defaultOptions Pgm.MigrationInitialization +``` + +or if you want to change the default options + +```haskell + let options = defaultOptions { optTransactionControl = TransactionPerRun, optVerbosity = Verbose } + runMigration con options Pgm.MigrationInitialization +``` + +That is all that needs to change. Your migrations scripts etc all remain as is. + + diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,2 @@ +> import Distribution.Simple +> main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,174 @@ +-- | +-- Module : Main +-- Copyright : (c) 2014 Andreas Meingast +-- +-- License : BSD-style +-- Maintainer : andre@andrevdm.com +-- Stability : experimental +-- Portability : GHC +-- +-- A standalone program for the postgresql-migration library. + +{-# LANGUAGE OverloadedStrings #-} + +module Main + ( main + ) where + +import Control.Exception +import Control.Monad (when) +import qualified Data.ByteString as BS (ByteString) +import qualified Data.ByteString.Char8 as BS8 (pack) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Database.PostgreSQL.Simple ( SqlError (..) + , connectPostgreSQL + ) +import Database.PostgreSQL.Simple.Migration ( MigrationCommand (..) + , MigrationOptions (..) + , MigrationResult (..) + , TransactionControl (..) + , Verbosity (..) + , defaultOptions + , runMigration + ) +import Data.Version (showVersion) +import System.Environment (getArgs) +import System.Exit (exitFailure, exitSuccess) +import System.IO (Handle, hPutStrLn, stdout, stderr) + +import qualified Paths_postgresql_migration as P + +main :: IO () +main = do + args <- getArgs + case collectArgs args (Verbose, TransactionPerRun) of + ArgPrintUsage -> printUsage stdout + ArgCommand (verbose, trn, rest) -> ppException $ run (parseCommand rest) verbose trn + + +data ArgAction + = ArgPrintUsage + | ArgCommand (Verbosity, TransactionControl, [[Char]]) + + +collectArgs :: [[Char]] -> (Verbosity, TransactionControl) -> ArgAction +collectArgs [] (v, t) = ArgCommand (v, t, []) +collectArgs (x:xs) (v, t) = + case x of + "-h" -> ArgPrintUsage + "-q" -> collectArgs xs (Quiet, t) + "-t" -> collectArgs xs (v, TransactionPerStep) + _ -> ArgCommand (v, t, x:xs) + + +-- | Pretty print postgresql-simple exceptions to see whats going on +ppException :: IO a -> IO a +ppException a = catch a ehandler + where + ehandler e = maybe (throw e) (*> exitFailure) (pSqlError <$> fromException e) + bsToString = T.unpack . T.decodeUtf8 + pSqlError e = mapM_ (hPutStrLn stderr) + [ "SqlError:" + , " sqlState: ", bsToString $ sqlState e + , " sqlExecStatus: ", show $ sqlExecStatus e + , " sqlErrorMsg: ", bsToString $ sqlErrorMsg e + , " sqlErrorDetail: ", bsToString $ sqlErrorDetail e + , " sqlErrorHint: ", bsToString $ sqlErrorHint e + ] + +run + :: Maybe Command + -> Verbosity + -> TransactionControl + -> IO () +run Nothing _ _ = printUsage stderr >> exitFailure +run (Just cmd) verbose trnControl = do + when (verbose == Verbose) $ do + putStrLn $ "postgresql-migration Version: " <> showVersion P.version + putStrLn $ "Verbosity: " <> show verbose + putStrLn $ "Transactions: " <> show trnControl + + handleResult =<< case cmd of + Initialize url tableName -> do + con <- connectPostgreSQL (BS8.pack url) + let opts = defaultOptions + { optTableName = tableName + , optVerbose = verbose + , optTransactionControl = trnControl + } + runMigration con opts MigrationInitialization + + Migrate url dir tableName -> do + con <- connectPostgreSQL (BS8.pack url) + let opts = defaultOptions + { optTableName = tableName + , optVerbose = verbose + , optTransactionControl = trnControl + } + runMigration con opts $ MigrationDirectory dir + + Validate url dir tableName -> do + con <- connectPostgreSQL $ BS8.pack url + let opts = defaultOptions + { optTableName = tableName + , optVerbose = verbose + , optTransactionControl = trnControl + } + runMigration con opts $ MigrationValidation (MigrationDirectory dir) + + where + handleResult MigrationSuccess = exitSuccess + handleResult (MigrationError _) = exitFailure + + +parseCommand :: [String] -> Maybe Command +parseCommand ("init":url:tableName:_) = Just (Initialize url (BS8.pack tableName)) +parseCommand ("migrate":url:dir:tableName:_) = Just (Migrate url dir (BS8.pack tableName)) +parseCommand ("validate":url:dir:tableName:_) = Just (Validate url dir (BS8.pack tableName)) +parseCommand ("init":url:_) = Just (Initialize url "schema_migrations") +parseCommand ("migrate":url:dir:_) = Just (Migrate url dir "schema_migrations") +parseCommand ("validate":url:dir:_) = Just (Validate url dir "schema_migrations") +parseCommand _ = Nothing + + +printUsage :: Handle -> IO () +printUsage h = do + hPutStrLn h "migrate [options] " + hPutStrLn h " Options:" + hPutStrLn h " -h Print help text" + hPutStrLn h " -q Enable quiet mode" + hPutStrLn h " -t Enable transaction per script" + hPutStrLn h " defauts to a single transaction for the entire migration(s)" + hPutStrLn h " Commands:" + hPutStrLn h " init {migrations table name}" + hPutStrLn h " Initialize the database. Required to be run" + hPutStrLn h " at least once." + hPutStrLn h " {migrations table name} is the optiona name." + hPutStrLn h " for the migrations table. This defaults to" + hPutStrLn h " `schema_migrations`." + hPutStrLn h " migrate {migrations table name}" + hPutStrLn h " Execute all SQL scripts in the provided" + hPutStrLn h " directory in alphabetical order." + hPutStrLn h " Scripts that have already been executed are" + hPutStrLn h " ignored. If a script was changed since the" + hPutStrLn h " time of its last execution, an error is" + hPutStrLn h " raised." + hPutStrLn h " {migrations table name} is the optiona name." + hPutStrLn h " for the migrations table. This defaults to" + hPutStrLn h " `schema_migrations`." + hPutStrLn h " validate {migrations table name}" + hPutStrLn h " Validate all SQL scripts in the provided" + hPutStrLn h " directory." + hPutStrLn h " {migrations table name} is the optiona name." + hPutStrLn h " for the migrations table. This defaults to" + hPutStrLn h " `schema_migrations`." + hPutStrLn h " The parameter is based on libpq connection string" + hPutStrLn h " syntax. Detailled information is available here:" + hPutStrLn h " " + + +data Command + = Initialize String BS.ByteString + | Migrate String FilePath BS.ByteString + | Validate String FilePath BS.ByteString diff --git a/postgresql-migration.cabal b/postgresql-migration.cabal new file mode 100644 --- /dev/null +++ b/postgresql-migration.cabal @@ -0,0 +1,106 @@ +cabal-version: 3.0 +name: postgresql-migration +version: 0.2.1.2 +synopsis: PostgreSQL Schema Migrations +homepage: https://github.com/andrevdm/postgresql-migration +Bug-reports: https://github.com/andrevdm/postgresql-migration/issues +license: BSD-3-Clause +license-file: License +author: Andreas Meingast +maintainer: Andre Van Der Merwe +copyright: 2014-2021, Andreas Meingast +category: Database +build-type: Simple +description: A PostgreSQL-simple schema migration utility +tested-with: GHC==9.0.1, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4 + +extra-source-files: License + Readme.markdown + Changelog.markdown + + share/test/*.sql + share/test/scripts/*.sql + +source-repository head + type: git + location: git://github.com/andrevdm/postgresql-migration + +common common-options + build-depends: + base >=4.9 && <5 + default-language: + Haskell2010 + + +common common-ghc-options-ide + ghc-options: -fwrite-ide-info -hiedir=.hie + +common common-ghc-options + ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wcompat -Wredundant-constraints -Wnoncanonical-monad-instances -Widentities -fhide-source-paths -Wpartial-fields -fhide-source-paths -freverse-errors + + +library + import: common-options + import: common-ghc-options + + if impl(ghc >= 8.8.1) + import: common-ghc-options-ide + + exposed-modules: Database.PostgreSQL.Simple.Migration + , Database.PostgreSQL.Simple.Migration.V1Compat + , Database.PostgreSQL.Simple.Util + other-modules: Paths_postgresql_migration + autogen-modules: Paths_postgresql_migration + hs-source-dirs: src + default-language: Haskell2010 + build-depends: base >= 4.9 && < 5.0 + , base64-bytestring >= 1.0 && < 1.3 + , bytestring >= 0.10 && < 0.11 + , cryptohash >= 0.11 && < 0.12 + , directory >= 1.2 && < 1.4 + , filepath >= 1.4.1.0 && < 1.4.3.0 + , postgresql-simple >= 0.4 && < 0.7 + , time >= 1.4 && < 1.10 + , text >= 1.2 && < 1.3 + +executable migrate + import: common-options + import: common-ghc-options + if impl(ghc >= 8.8.1) + import: common-ghc-options-ide + + ghc-options: -threaded + main-is: Main.hs + other-modules: Paths_postgresql_migration + autogen-modules: Paths_postgresql_migration + hs-source-dirs: app + default-language: Haskell2010 + build-depends: postgresql-migration + , base >= 4.9 && < 5.0 + , base64-bytestring >= 1.0 && < 1.3 + , bytestring >= 0.10 && < 0.11 + , cryptohash >= 0.11 && < 0.12 + , directory >= 1.2 && < 1.4 + , postgresql-simple >= 0.4 && < 0.7 + , time >= 1.4 && < 1.10 + , text >= 1.2 && < 1.3 + +test-suite tests + import: common-options + import: common-ghc-options + if impl(ghc >= 8.8.1) + import: common-ghc-options-ide + + main-is: Main.hs + hs-source-dirs: test + other-modules: Database.PostgreSQL.Simple.MigrationTest + , Database.PostgreSQL.Simple.MigrationTestV1Compat + , Database.PostgreSQL.Simple.TransactionPerRunTest + , Database.PostgreSQL.Simple.TransactionPerStepTest + default-language: Haskell2010 + type: exitcode-stdio-1.0 + build-depends: postgresql-migration + , base >= 4.9 && < 5.0 + , bytestring >= 0.10 && < 0.11 + , postgresql-simple >= 0.4 && < 0.7 + , hspec >= 2.2 && < 2.8 diff --git a/share/test/script.sql b/share/test/script.sql new file mode 100644 --- /dev/null +++ b/share/test/script.sql @@ -0,0 +1,1 @@ +create table t3 (c3 varchar); diff --git a/share/test/scripts/1.sql b/share/test/scripts/1.sql new file mode 100644 --- /dev/null +++ b/share/test/scripts/1.sql @@ -0,0 +1,1 @@ +create table t2 (c2 varchar); diff --git a/src/Database/PostgreSQL/Simple/Migration.hs b/src/Database/PostgreSQL/Simple/Migration.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Migration.hs @@ -0,0 +1,426 @@ +-- | +-- Module : Database.PostgreSQL.Simple.Migration +-- Copyright : (c) 2014 Andreas Meingast +-- +-- License : BSD-style +-- Maintainer : andre@andrevdm.com +-- Stability : experimental +-- Portability : GHC +-- +-- A migration library for postgresql-simple. +-- +-- For usage, see Readme.markdown. + +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Database.PostgreSQL.Simple.Migration + ( + -- * Migration actions + defaultOptions + , runMigration + , runMigrations + , sequenceMigrations + + -- * Migration types + , Checksum + , MigrationOptions(..) + , MigrationCommand(..) + , MigrationResult(..) + , ScriptName + , TransactionControl(..) + , Verbosity(..) + + -- * Migration result actions + , getMigrations + , getMigrations' + + -- * Migration result types + , SchemaMigration(..) + ) where + +import Control.Monad (void, when) +import qualified Crypto.Hash.MD5 as MD5 (hash) +import qualified Data.ByteString as BS (ByteString, readFile) +import qualified Data.ByteString.Char8 as BS8 (unpack) +import qualified Data.ByteString.Base64 as B64 (encode) +import Data.Functor ((<&>)) +import Data.List (isPrefixOf, sort) +import Data.Time (LocalTime) +import qualified Data.Text as T +import qualified Data.Text.IO as T (putStrLn, hPutStrLn) +import Data.String (fromString) +import Database.PostgreSQL.Simple ( Connection + , Only (..) + , execute + , execute_ + , query + , query_ + , withTransaction + ) +import Database.PostgreSQL.Simple.FromRow (FromRow (..), field) +import Database.PostgreSQL.Simple.ToField (ToField (..)) +import Database.PostgreSQL.Simple.ToRow (ToRow (..)) +import Database.PostgreSQL.Simple.Types (Query (..)) +import Database.PostgreSQL.Simple.Util (existsTable) +import System.Directory (getDirectoryContents) +import System.FilePath (()) +import System.IO (stderr) + +-- | Executes migrations inside the provided 'MigrationContext'. +-- +-- Returns 'MigrationSuccess' if the provided 'MigrationCommand' executes +-- without error. If an error occurs, execution is stopped and +-- a 'MigrationError' is returned. +runMigration :: Connection -> MigrationOptions -> MigrationCommand -> IO (MigrationResult String) +runMigration con opts cmd = runMigrations' True con opts [cmd] + + +-- | Execute a sequence of migrations +-- +-- Returns 'MigrationSuccess' if all of the provided 'MigrationCommand's +-- execute without error. If an error occurs, execution is stopped and the +-- 'MigrationError' is returned. +runMigrations + :: Connection -- ^ The postgres connection to use + -> MigrationOptions -- ^ The options for this migration + -> [MigrationCommand] -- ^ The commands to run + -> IO (MigrationResult String) +runMigrations = runMigrations' True + + + +-- | Implements runMigration. Ensure that 'doRunTransaction' is only called on the first run +runMigration' :: Connection -> MigrationOptions -> MigrationCommand -> IO (MigrationResult String) +runMigration' con opts cmd = + case cmd of + MigrationInitialization -> + initializeSchema con opts >> pure MigrationSuccess + MigrationDirectory path -> + executeDirectoryMigration con opts path + MigrationScript name contents -> + executeMigration con opts name contents + MigrationFile name path -> + executeMigration con opts name =<< BS.readFile path + MigrationValidation validationCmd -> + executeValidation con opts validationCmd + MigrationCommands commands -> + runMigrations' False con opts commands + + +-- | Implements runMigrations +runMigrations' + :: Bool -- ^ Is this the first/top-level call + -> Connection -- ^ The postgres connection to use + -> MigrationOptions -- ^ The options for this migration + -> [MigrationCommand] -- ^ The commands to run + -> IO (MigrationResult String) +runMigrations' isFirst con opts commands = + if isFirst + then doRunTransaction opts con go + else go + where + go = sequenceMigrations [runMigration' con opts c | c <- commands] + + + +-- | Run a sequence of contexts, stopping on the first failure +sequenceMigrations + :: Monad m + => [m (MigrationResult e)] + -> m (MigrationResult e) +sequenceMigrations = \case + [] -> pure MigrationSuccess + c:cs -> do + r <- c + case r of + MigrationError s -> pure (MigrationError s) + MigrationSuccess -> sequenceMigrations cs + +-- | Executes all SQL-file based migrations located in the provided 'dir' +-- in alphabetical order. +executeDirectoryMigration + :: Connection + -> MigrationOptions + -> FilePath + -> IO (MigrationResult String) +executeDirectoryMigration con opts dir = + scriptsInDirectory dir >>= go + where + go fs = sequenceMigrations (executeMigrationFile <$> fs) + executeMigrationFile f = + BS.readFile (dir f) >>= executeMigration con opts f + + +-- | Lists all files in the given 'FilePath' 'dir' in alphabetical order. +scriptsInDirectory :: FilePath -> IO [String] +scriptsInDirectory dir = + getDirectoryContents dir <&> (sort . filter (\x -> not $ "." `isPrefixOf` x)) + + +-- | Executes a generic SQL migration for the provided script 'name' with content 'contents'. +executeMigration + :: Connection + -> MigrationOptions + -> ScriptName + -> BS.ByteString + -> IO (MigrationResult String) +executeMigration con opts name contents = doStepTransaction opts con $ do + let checksum = md5Hash contents + checkScript con opts name checksum >>= \case + ScriptOk -> do + when (verbose opts) $ optLogWriter opts $ Right $ "Ok:\t" <> fromString name + pure MigrationSuccess + ScriptNotExecuted -> do + void $ execute_ con (Query contents) + void $ execute con q (name, checksum) + when (verbose opts) $ optLogWriter opts $ Right ("Execute:\t" <> fromString name) + pure MigrationSuccess + ScriptModified eva -> do + when (verbose opts) $ optLogWriter opts $ Left ("Fail:\t" <> fromString name <> "\n" <> scriptModifiedErrorMessage eva) + pure (MigrationError name) + where + q = "insert into " <> Query (optTableName opts) <> "(filename, checksum) values(?, ?)" + +-- | Initializes the database schema with a helper table containing +-- meta-information about executed migrations. +initializeSchema :: Connection -> MigrationOptions -> IO () +initializeSchema con opts = do + when (verbose opts) $ optLogWriter opts $ Right "Initializing schema" + void . doStepTransaction opts con . execute_ con $ mconcat + [ "create table if not exists " <> Query (optTableName opts) <> " " + , "( filename varchar(512) not null" + , ", checksum varchar(32) not null" + , ", executed_at timestamp without time zone not null default now() " + , ");" + ] + + +-- | Validates a 'MigrationCommand'. Validation is defined as follows for these types: +-- +-- * 'MigrationInitialization': validate the presence of the meta-information table. +-- * 'MigrationDirectory': validate the presence and checksum of all scripts found in the given directory. +-- * 'MigrationScript': validate the presence and checksum of the given script. +-- * 'MigrationFile': validate the presence and checksum of the given file. +-- * 'MigrationValidation': always succeeds. +-- * 'MigrationCommands': validates all the sub-commands stopping at the first failure. +executeValidation + :: Connection + -> MigrationOptions + -> MigrationCommand + -> IO (MigrationResult String) +executeValidation con opts cmd = doStepTransaction opts con $ + case cmd of + MigrationInitialization -> + existsTable con (BS8.unpack $ optTableName opts) >>= \r -> pure $ if r + then MigrationSuccess + else MigrationError ("No such table: " <> BS8.unpack (optTableName opts)) + MigrationDirectory path -> + scriptsInDirectory path >>= goScripts path + MigrationScript name contents -> + validate name contents + MigrationFile name path -> + validate name =<< BS.readFile path + MigrationValidation _ -> + pure MigrationSuccess + MigrationCommands cs -> + sequenceMigrations (executeValidation con opts <$> cs) + where + validate name contents = + checkScript con opts name (md5Hash contents) >>= \case + ScriptOk -> do + when (verbose opts) $ optLogWriter opts (Right $ "Ok:\t" <> fromString name) + pure MigrationSuccess + ScriptNotExecuted -> do + when (verbose opts) $ optLogWriter opts (Left $ "Missing:\t" <> fromString name) + pure (MigrationError $ "Missing: " <> name) + ScriptModified eva -> do + when (verbose opts) $ optLogWriter opts (Left $ "Checksum mismatch:\t" <> fromString name <> "\n" <> scriptModifiedErrorMessage eva) + pure (MigrationError $ "Checksum mismatch: " <> name) + + goScripts path xs = sequenceMigrations (goScript path <$> xs) + goScript path x = validate x =<< BS.readFile (path x) + + +-- | Checks the status of the script with the given name 'name'. +-- If the script has already been executed, the checksum of the script +-- is compared against the one that was executed. +-- If there is no matching script entry in the database, the script +-- will be executed and its meta-information will be recorded. +checkScript :: Connection -> MigrationOptions -> ScriptName -> Checksum -> IO CheckScriptResult +checkScript con opts name fileChecksum = + query con q (Only name) >>= \case + [] -> + pure ScriptNotExecuted + Only dbChecksum:_ | fileChecksum == dbChecksum -> + pure ScriptOk + Only dbChecksum:_ -> + pure $ ScriptModified (ExpectedVsActual {evaExpected = dbChecksum, evaActual = fileChecksum}) + where + q = mconcat + [ "select checksum from " <> Query (optTableName opts) <> " " + , "where filename = ? limit 1" + ] + +-- | Calculates the MD5 checksum of the provided bytestring in base64 +-- encoding. +md5Hash :: BS.ByteString -> Checksum +md5Hash = B64.encode . MD5.hash + +-- | The checksum type of a migration script. +type Checksum = BS.ByteString + +-- | The name of a script. Typically the filename or a custom name +-- when using Haskell migrations. +type ScriptName = String + +-- | 'MigrationCommand' determines the action of the 'runMigration' script. +data MigrationCommand + = MigrationInitialization + -- ^ Initializes the database with a helper table containing meta + -- information. + | MigrationDirectory FilePath + -- ^ Executes migrations based on SQL scripts in the provided 'FilePath' + -- in alphabetical order. + | MigrationFile ScriptName FilePath + -- ^ Executes a migration based on script located at the provided + -- 'FilePath'. + | MigrationScript ScriptName BS.ByteString + -- ^ Executes a migration based on the provided bytestring. + | MigrationValidation MigrationCommand + -- ^ Validates that the provided MigrationCommand has been executed. + | MigrationCommands [MigrationCommand] + -- ^ Performs a series of 'MigrationCommand's in sequence. + deriving (Show, Eq, Read, Ord) + +instance Semigroup MigrationCommand where + (<>) (MigrationCommands xs) (MigrationCommands ys) = MigrationCommands (xs <> ys) + (<>) (MigrationCommands xs) y = MigrationCommands (xs <> [y]) + (<>) x (MigrationCommands ys) = MigrationCommands (x : ys) + (<>) x y = MigrationCommands [x, y] + +instance Monoid MigrationCommand where + mempty = MigrationCommands [] + mappend = (<>) + +data ExpectedVsActual a = ExpectedVsActual + { evaExpected :: !a + , evaActual :: !a + } deriving (Show) + +-- | A sum-type denoting the result of a single migration. +data CheckScriptResult + = ScriptOk + -- ^ The script has already been executed and the checksums match. + -- This is good. + | ScriptModified (ExpectedVsActual Checksum) + -- ^ The script has already been executed and there is a checksum + -- mismatch. This is bad. + | ScriptNotExecuted + -- ^ The script has not been executed, yet. This is good. + deriving (Show) + +scriptModifiedErrorMessage :: ExpectedVsActual Checksum -> T.Text +scriptModifiedErrorMessage (ExpectedVsActual expected actual) = + "expected: " <> fromString (show expected) <> "\nhash was: " <> fromString (show actual) + +-- | A sum-type denoting the result of a migration. +data MigrationResult a + = MigrationError a + -- ^ There was an error in script migration. + | MigrationSuccess + -- ^ All scripts have been executed successfully. + deriving (Show, Eq, Read, Ord, Functor, Foldable, Traversable) + +data Verbosity + = Verbose + | Quiet + deriving (Show, Eq) + +-- | Determines how transactions are handled +-- Its is recommened to use transaction when running migrations +-- Certain actions require a transaction per script, if you are doing this use TransactionPerStep +-- If you want a single transaction for all migrations use TransactionPerRun +-- If you do not want a transaction, or are using an existing transaction then use NoNewTransaction +data TransactionControl + = NoNewTransaction -- ^ No new transaction will be started. Up to the caller to decide if the run is in a transaction or not + | TransactionPerRun -- ^ Call 'withTransaction' once for the entire 'MigrationCommand' + | TransactionPerStep -- ^ Call 'withTransaction' once for each step in a 'MigrationCommand' (i.e. new transaction per script) + deriving (Show) + + +data MigrationOptions = MigrationOptions + { optVerbose :: !Verbosity + -- ^ Verbosity of the library. + , optTableName :: !BS.ByteString + -- ^ The name of the table that stores the migrations, usually "schema_migrations" + , optLogWriter :: !(Either T.Text T.Text -> IO ()) + -- ^ Logger. 'Either' indicates log level, + -- 'Left' for an error message and 'Right' for an info message. + , optTransactionControl :: !TransactionControl + -- ^ If/when transactions should be started + } + +defaultOptions :: MigrationOptions +defaultOptions = + MigrationOptions + { optVerbose = Quiet + , optTableName = "schema_migrations" + , optLogWriter = either (T.hPutStrLn stderr) T.putStrLn + , optTransactionControl = TransactionPerRun + } + +verbose :: MigrationOptions -> Bool +verbose o = optVerbose o == Verbose + + +doRunTransaction :: MigrationOptions -> Connection -> IO a -> IO a +doRunTransaction opts con act = + case optTransactionControl opts of + NoNewTransaction -> act + TransactionPerRun -> withTransaction con act + TransactionPerStep -> act + + +doStepTransaction :: MigrationOptions -> Connection -> IO a -> IO a +doStepTransaction opts con act = + case optTransactionControl opts of + NoNewTransaction -> act + TransactionPerRun -> act + TransactionPerStep -> withTransaction con act + + +-- | Produces a list of all executed 'SchemaMigration's in the default schema_migrations table +getMigrations :: Connection -> IO [SchemaMigration] +getMigrations con = getMigrations' con "schema_migrations" + +-- | Produces a list of all executed 'SchemaMigration's. +getMigrations' :: Connection -> BS.ByteString -> IO [SchemaMigration] +getMigrations' con tableName = query_ con q + where q = mconcat + [ "select filename, checksum, executed_at " + , "from " <> Query tableName <> " order by executed_at asc" + ] + +-- | A product type representing a single, executed 'SchemaMigration'. +data SchemaMigration = SchemaMigration + { schemaMigrationName :: BS.ByteString + -- ^ The name of the executed migration. + , schemaMigrationChecksum :: Checksum + -- ^ The calculated MD5 checksum of the executed script. + , schemaMigrationExecutedAt :: LocalTime + -- ^ A timestamp without timezone of the date of execution of the script. + } deriving (Show, Eq, Read) + +instance Ord SchemaMigration where + compare (SchemaMigration nameLeft _ _) (SchemaMigration nameRight _ _) = + compare nameLeft nameRight + +instance FromRow SchemaMigration where + fromRow = SchemaMigration <$> + field <*> field <*> field + +instance ToRow SchemaMigration where + toRow (SchemaMigration name checksum executedAt) = + [toField name, toField checksum, toField executedAt] diff --git a/src/Database/PostgreSQL/Simple/Migration/V1Compat.hs b/src/Database/PostgreSQL/Simple/Migration/V1Compat.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Migration/V1Compat.hs @@ -0,0 +1,72 @@ +-- | +-- Module : Database.PostgreSQL.Simple.Migration +-- Copyright : (c) 2014 Andreas Meingast +-- +-- License : BSD-style +-- Maintainer : andre@andrevdm.com +-- Stability : experimental +-- Portability : GHC +-- +-- A migration library for postgresql-simple. +-- +-- For usage, see Readme.markdown. + +{-# LANGUAGE OverloadedStrings #-} + +module Database.PostgreSQL.Simple.Migration.V1Compat + ( + -- * Migration actions + runMigration + , runMigrations + , V2.sequenceMigrations + + -- * Migration types + , MigrationContext(..) + + , V2.MigrationCommand(..) + , V2.MigrationResult(..) + , V2.ScriptName + , V2.Checksum + + -- * Migration result actions + , V2.getMigrations + + -- * Migration result types + , V2.SchemaMigration(..) + ) where + + +import Database.PostgreSQL.Simple (Connection) +import qualified Database.PostgreSQL.Simple.Migration as V2 + + +runMigration :: MigrationContext -> IO (V2.MigrationResult [Char]) +runMigration (MigrationContext cmd verbose con) = runMigrations verbose con [cmd] + + +runMigrations + :: Bool + -- ^ Run in verbose mode + -> Connection + -- ^ The postgres connection to use + -> [V2.MigrationCommand] + -- ^ The commands to run + -> IO (V2.MigrationResult String) +runMigrations verbose con commands = do + let opts = V2.defaultOptions + { V2.optVerbose = if verbose then V2.Verbose else V2.Quiet + , V2.optTableName = "schema_migrations" + , V2.optTransactionControl = V2.NoNewTransaction + } + V2.runMigrations con opts commands + + +-- | The 'MigrationContext' provides an execution context for migrations. +data MigrationContext = MigrationContext + { migrationContextCommand :: V2.MigrationCommand + -- ^ The action that will be performed by 'runMigration' + , migrationContextVerbose :: Bool + -- ^ Verbosity of the library. + , migrationContextConnection :: Connection + -- ^ The PostgreSQL connection to use for migrations. + } diff --git a/src/Database/PostgreSQL/Simple/Util.hs b/src/Database/PostgreSQL/Simple/Util.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Util.hs @@ -0,0 +1,43 @@ +-- | +-- Module : Database.PostgreSQL.Simple.Util +-- Copyright : (c) 2014 Andreas Meingast +-- +-- License : BSD-style +-- Maintainer : andre@andrevdm.com +-- Stability : experimental +-- Portability : GHC +-- +-- A collection of utilites for database migrations. + +{-# LANGUAGE OverloadedStrings #-} + +module Database.PostgreSQL.Simple.Util + ( existsTable + , withTransactionRolledBack + ) where + +import Control.Exception ( finally ) +import Database.PostgreSQL.Simple ( Connection + , Only (..) + , begin + , query + , rollback + ) +import GHC.Int (Int64) + +-- | Checks if the table with the given name exists in the database. +existsTable :: Connection -> String -> IO Bool +existsTable con table = + checkRowCount <$> (query con q (Only table) :: IO [[Int64]]) + where + q = "select count(relname) from pg_class where relname = ?" + + checkRowCount :: [[Int64]] -> Bool + checkRowCount ((1:_):_) = True + checkRowCount _ = False + +-- | Executes the given IO monad inside a transaction and performs a roll-back +-- afterwards (even if exceptions occur). +withTransactionRolledBack :: Connection -> IO a -> IO a +withTransactionRolledBack con f = + begin con >> finally f (rollback con) diff --git a/test/Database/PostgreSQL/Simple/MigrationTest.hs b/test/Database/PostgreSQL/Simple/MigrationTest.hs new file mode 100644 --- /dev/null +++ b/test/Database/PostgreSQL/Simple/MigrationTest.hs @@ -0,0 +1,117 @@ +-- | +-- Module : Database.PostgreSQL.Simple.MigrationTest +-- Copyright : (c) 2014 Andreas Meingast +-- +-- License : BSD-style +-- Maintainer : andre@andrevdm.com +-- Stability : experimental +-- Portability : GHC +-- +-- A collection of postgresql-migration specifications. + +{-# LANGUAGE OverloadedStrings #-} + +module Database.PostgreSQL.Simple.MigrationTest where + +import Data.IORef +import Database.PostgreSQL.Simple (Connection) +import Database.PostgreSQL.Simple.Migration (MigrationCommand (..), + MigrationOptions (..), + MigrationResult (..), + SchemaMigration (..), + TransactionControl (..), + Verbosity(..), + getMigrations, + runMigration, + defaultOptions) +import Database.PostgreSQL.Simple.Util (existsTable) +import Test.Hspec (Spec, describe, it, shouldBe) + +migrationSpec :: Connection -> Spec +migrationSpec con = describe "Migrations" $ do + let + migrationScript = MigrationScript "test.sql" q + migrationScriptAltered = MigrationScript "test.sql" "" + migrationDir = MigrationDirectory "share/test/scripts" + migrationFile = MigrationFile "s.sql" "share/test/script.sql" + + it "asserts that the schema_migrations table does not exist" $ do + r <- existsTable con "schema_migrations" + r `shouldBe` False + + it "validates an initialization on an empty database" $ do + r <- runMigration' (MigrationValidation MigrationInitialization) + r `shouldBe` MigrationError "No such table: schema_migrations" + + it "initializes a database" $ do + r <- runMigration' MigrationInitialization + r `shouldBe` MigrationSuccess + + it "creates the schema_migrations table" $ do + r <- existsTable con "schema_migrations" + r `shouldBe` True + + it "executes a migration script" $ do + r <- runMigration' migrationScript + r `shouldBe` MigrationSuccess + + it "creates the table from the executed script" $ do + r <- existsTable con "t1" + r `shouldBe` True + + it "skips execution of the same migration script" $ do + r <- runMigration' migrationScript + r `shouldBe` MigrationSuccess + + it "reports an error on a different checksum for the same script" $ do + r <- runMigration' migrationScriptAltered + r `shouldBe` MigrationError "test.sql" + + it "executes migration scripts inside a folder" $ do + r <- runMigration' migrationDir + r `shouldBe` MigrationSuccess + + it "creates the table from the executed scripts" $ do + r <- existsTable con "t2" + r `shouldBe` True + + it "executes a file based migration script" $ do + r <- runMigration' migrationFile + r `shouldBe` MigrationSuccess + + it "creates the table from the executed scripts" $ do + r <- existsTable con "t3" + r `shouldBe` True + + it "validates initialization" $ do + r <- runMigration' $ MigrationValidation MigrationInitialization + r `shouldBe` MigrationSuccess + + it "validates an executed migration script" $ do + r <- runMigration' $ MigrationValidation migrationScript + r `shouldBe` MigrationSuccess + + it "validates all scripts inside a folder" $ do + r <- runMigration' $ MigrationValidation migrationDir + r `shouldBe` MigrationSuccess + + it "validates an executed migration file" $ do + r <- runMigration' $ MigrationValidation migrationFile + r `shouldBe` MigrationSuccess + + it "gets a list of executed migrations" $ do + r <- getMigrations con + map schemaMigrationName r `shouldBe` ["test.sql", "1.sql", "s.sql"] + + it "log can be redirected" $ do + ref <- newIORef mempty + let logWrite = modifyIORef ref . (<>) . show + let opts = defaultOptions{ optLogWriter = logWrite, optVerbose = Verbose, optTransactionControl = NoNewTransaction } + _ <- runMigration con opts MigrationInitialization + readIORef ref >>= (`shouldBe` "Right \"Initializing schema\"") + + where + q = "create table t1 (c1 varchar);" + runMigration' = + runMigration con defaultOptions{optTransactionControl = NoNewTransaction} + diff --git a/test/Database/PostgreSQL/Simple/MigrationTestV1Compat.hs b/test/Database/PostgreSQL/Simple/MigrationTestV1Compat.hs new file mode 100644 --- /dev/null +++ b/test/Database/PostgreSQL/Simple/MigrationTestV1Compat.hs @@ -0,0 +1,109 @@ +-- | +-- Module : Database.PostgreSQL.Simple.MigrationTest +-- Copyright : (c) 2014 Andreas Meingast +-- +-- License : BSD-style +-- Maintainer : andre@andrevdm.com +-- Stability : experimental +-- Portability : GHC +-- +-- A collection of postgresql-migration specifications. + +{-# LANGUAGE OverloadedStrings #-} + +module Database.PostgreSQL.Simple.MigrationTestV1Compat where + +import Database.PostgreSQL.Simple (Connection) +import Database.PostgreSQL.Simple.Migration.V1Compat (MigrationCommand (..), + MigrationContext (..), + MigrationResult (..), + SchemaMigration (..), + getMigrations, + runMigration) +import Database.PostgreSQL.Simple.Util (existsTable) +import Test.Hspec (Spec, describe, it, + shouldBe) + +migrationSpec:: Connection -> Spec +migrationSpec con = describe "Migrations" $ do + let migrationScript = MigrationScript "test.sql" q + let migrationScriptAltered = MigrationScript "test.sql" "" + let migrationDir = MigrationDirectory "share/test/scripts" + let migrationFile = MigrationFile "s.sql" "share/test/script.sql" + + it "asserts that the schema_migrations table does not exist" $ do + r <- existsTable con "schema_migrations" + r `shouldBe` False + + it "validates an initialization on an empty database" $ do + r <- runMigration $ MigrationContext + (MigrationValidation MigrationInitialization) False con + r `shouldBe` MigrationError "No such table: schema_migrations" + + it "initializes a database" $ do + r <- runMigration $ MigrationContext MigrationInitialization False con + r `shouldBe` MigrationSuccess + + it "creates the schema_migrations table" $ do + r <- existsTable con "schema_migrations" + r `shouldBe` True + + it "executes a migration script" $ do + r <- runMigration $ MigrationContext migrationScript False con + r `shouldBe` MigrationSuccess + + it "creates the table from the executed script" $ do + r <- existsTable con "t1" + r `shouldBe` True + + it "skips execution of the same migration script" $ do + r <- runMigration $ + MigrationContext migrationScript False con + r `shouldBe` MigrationSuccess + + it "reports an error on a different checksum for the same script" $ do + r <- runMigration $ MigrationContext migrationScriptAltered False con + r `shouldBe` MigrationError "test.sql" + + it "executes migration scripts inside a folder" $ do + r <- runMigration $ MigrationContext migrationDir False con + r `shouldBe` MigrationSuccess + + it "creates the table from the executed scripts" $ do + r <- existsTable con "t2" + r `shouldBe` True + + it "executes a file based migration script" $ do + r <- runMigration $ MigrationContext migrationFile False con + r `shouldBe` MigrationSuccess + + it "creates the table from the executed scripts" $ do + r <- existsTable con "t3" + r `shouldBe` True + + it "validates initialization" $ do + r <- runMigration $ MigrationContext + (MigrationValidation MigrationInitialization) False con + r `shouldBe` MigrationSuccess + + it "validates an executed migration script" $ do + r <- runMigration $ MigrationContext + (MigrationValidation migrationScript) False con + r `shouldBe` MigrationSuccess + + it "validates all scripts inside a folder" $ do + r <- runMigration $ MigrationContext + (MigrationValidation migrationDir) False con + r `shouldBe` MigrationSuccess + + it "validates an executed migration file" $ do + r <- runMigration $ MigrationContext + (MigrationValidation migrationFile) False con + r `shouldBe` MigrationSuccess + + it "gets a list of executed migrations" $ do + r <- getMigrations con + map schemaMigrationName r `shouldBe` ["test.sql", "1.sql", "s.sql"] + + where + q = "create table t1 (c1 varchar);" diff --git a/test/Database/PostgreSQL/Simple/TransactionPerRunTest.hs b/test/Database/PostgreSQL/Simple/TransactionPerRunTest.hs new file mode 100644 --- /dev/null +++ b/test/Database/PostgreSQL/Simple/TransactionPerRunTest.hs @@ -0,0 +1,66 @@ +-- | +-- Module : Database.PostgreSQL.Simple.MigrationTest +-- Copyright : (c) 2014 Andreas Meingast +-- +-- License : BSD-style +-- Maintainer : andre@andrevdm.com +-- Stability : experimental +-- Portability : GHC +-- +-- A collection of postgresql-migration specifications. + +{-# LANGUAGE OverloadedStrings #-} + +module Database.PostgreSQL.Simple.TransactionPerRunTest where + +import Database.PostgreSQL.Simple (Connection) +import Database.PostgreSQL.Simple.Migration (MigrationCommand (..), + MigrationOptions (..), + MigrationResult (..), + TransactionControl (..), + runMigration, + runMigrations, + defaultOptions) +import Database.PostgreSQL.Simple.Util (existsTable) +import Test.Hspec (Spec, describe, it, shouldBe, shouldThrow, anyException) + +migrationSpec :: Connection -> Spec +migrationSpec con = describe "Migrations" $ do + let + scriptCreate1 = MigrationScript "create1.sql" "create table trn1 (c2 varchar);" + scriptError1 = MigrationScript "errorScript.sql" "NOT SQL!" + + it "asserts that the test table does not exist" $ do + r <- existsTable con "trn1" + r `shouldBe` False + + it "asserts that the test table does not exist" $ do + r <- existsTable con "trn2" + r `shouldBe` False + + it "validates an initialization on an empty database" $ do + r <- runMigration' (MigrationValidation MigrationInitialization) + r `shouldBe` MigrationError "No such table: schema_migrations" + + it "initializes a database" $ do + r <- runMigration' MigrationInitialization + r `shouldBe` MigrationSuccess + + it "creates the schema_migrations table" $ do + r <- existsTable con "schema_migrations" + r `shouldBe` True + + -- This test shoud thow an exception since the second migration script is invalid SQL + it "executes a migration script" $ (`shouldThrow` anyException) $ do + let opts = defaultOptions{optTransactionControl = TransactionPerRun} + runMigrations con opts [scriptCreate1, scriptError1] + + -- The second migration script failed, so the changes from the first should be rolled back (TransactionPerRun) + it "creates the table from the executed script" $ do + r <- existsTable con "trn1" + r `shouldBe` False + + + where + runMigration' = + runMigration con defaultOptions{optTransactionControl = NoNewTransaction} diff --git a/test/Database/PostgreSQL/Simple/TransactionPerStepTest.hs b/test/Database/PostgreSQL/Simple/TransactionPerStepTest.hs new file mode 100644 --- /dev/null +++ b/test/Database/PostgreSQL/Simple/TransactionPerStepTest.hs @@ -0,0 +1,75 @@ +-- | +-- Module : Database.PostgreSQL.Simple.MigrationTest +-- Copyright : (c) 2014 Andreas Meingast +-- +-- License : BSD-style +-- Maintainer : andre@andrevdm.com +-- Stability : experimental +-- Portability : GHC +-- +-- A collection of postgresql-migration specifications. + +{-# LANGUAGE OverloadedStrings #-} + +module Database.PostgreSQL.Simple.TransactionPerStepTest where + +import Database.PostgreSQL.Simple (Connection, execute_) +import Database.PostgreSQL.Simple.Migration (MigrationCommand (..), + MigrationOptions (..), + MigrationResult (..), + TransactionControl (..), + runMigration, + runMigrations, + defaultOptions) +import Database.PostgreSQL.Simple.Util (existsTable) +import Test.Hspec (Spec, describe, it, shouldBe, shouldThrow, anyException, afterAll_) + +migrationSpec :: Connection -> Spec +migrationSpec con = afterAll_ cleanup $ describe "Migrations" $ do + let + scriptCreate2 = MigrationScript "create2.sql" "create table trn2 (c2 varchar);" + scriptError2 = MigrationScript "errorScript.sql" "ALSO NOT SQL!" + + it "asserts that the test table does not exist" $ do + r <- existsTable con "trn1" + r `shouldBe` False + + it "asserts that the test table does not exist" $ do + r <- existsTable con "trn2" + r `shouldBe` False + + it "validates an initialization on an empty database" $ do + r <- runMigration' (MigrationValidation MigrationInitialization) + r `shouldBe` MigrationError "No such table: schema_migrations" + + it "initializes a database" $ do + r <- runMigration' MigrationInitialization + r `shouldBe` MigrationSuccess + + it "creates the schema_migrations table" $ do + r <- existsTable con "schema_migrations" + r `shouldBe` True + + -- This test shoud thow an exception since the second migration script is invalid SQL + it "executes a migration script" $ (`shouldThrow` anyException) $ do + let opts = defaultOptions{optTransactionControl = TransactionPerStep} + r <- runMigrations con opts [scriptCreate2, scriptError2] + r `shouldBe` MigrationSuccess + + -- Since TransactionPerStep was used the first migration should have been committed even though the second one failed + it "creates the table from the executed script" $ do + r <- existsTable con "trn2" + r `shouldBe` True + + + where + runMigration' = + runMigration con defaultOptions{optTransactionControl = NoNewTransaction} + + -- Cleanup + cleanup = do + _ <- execute_ con "drop table if exists trn2" + _ <- execute_ con "drop table if exists schema_migrations" + pure () + + diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,34 @@ +-- | +-- Module : Main +-- Copyright : (c) 2014 Andreas Meingast +-- +-- License : BSD-style +-- Maintainer : andre@andrevdm.com +-- Stability : experimental +-- Portability : GHC +-- +-- The test entry-point for postgresql-migration. + +{-# LANGUAGE OverloadedStrings #-} + +module Main + ( main + ) where + +import Database.PostgreSQL.Simple (connectPostgreSQL) +import qualified Database.PostgreSQL.Simple.MigrationTestV1Compat as V1 +import qualified Database.PostgreSQL.Simple.MigrationTest as V2 +import qualified Database.PostgreSQL.Simple.TransactionPerRunTest as V2TrnRun +import qualified Database.PostgreSQL.Simple.TransactionPerStepTest as V2TrnStep +import Database.PostgreSQL.Simple.Util (withTransactionRolledBack) +import Test.Hspec (hspec) + +main :: IO () +main = do + conRollback <- connectPostgreSQL "" + withTransactionRolledBack conRollback (hspec (V2.migrationSpec conRollback)) + withTransactionRolledBack conRollback (hspec (V1.migrationSpec conRollback)) + withTransactionRolledBack conRollback (hspec (V2TrnRun.migrationSpec conRollback)) + + conPerStep <- connectPostgreSQL "" + hspec (V2TrnStep.migrationSpec conPerStep)