├── .ghci ├── .gitignore ├── .travis.yml ├── Changelog.markdown ├── License ├── Readme.markdown ├── Setup.lhs ├── postgresql-simple-migration.cabal ├── share └── test │ ├── script.sql │ └── scripts │ └── 1.sql ├── src ├── Database │ └── PostgreSQL │ │ └── Simple │ │ ├── Migration.hs │ │ └── Util.hs └── Main.hs └── test ├── Database └── PostgreSQL │ └── Simple │ └── MigrationTest.hs └── Main.hs /.ghci: -------------------------------------------------------------------------------- 1 | :set -isrc 2 | :set Wall 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .DS_Store 2 | *.hi 3 | *.o 4 | *.swp 5 | *.prof 6 | dist/ 7 | .cabal-sandbox 8 | cabal.sandbox.config 9 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | sudo: required 2 | 3 | services: 4 | - postgresql 5 | 6 | before_script: 7 | - psql -c 'create database test;' -U postgres 8 | 9 | env: 10 | - CABALVER=1.24 GHCVER=8.0.2 11 | - CABALVER=2.0 GHCVER=8.2.2 12 | - CABALVER=2.2 GHCVER=8.4.3 13 | - CABALVER=2.4 GHCVER=8.6.4 14 | 15 | before_install: 16 | - travis_retry sudo add-apt-repository -y ppa:hvr/ghc 17 | - travis_retry sudo apt-get update 18 | - travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER 19 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH 20 | 21 | install: 22 | - cabal --version 23 | - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" 24 | - travis_retry cabal update 25 | - cabal install --only-dependencies --enable-tests --enable-benchmarks 26 | 27 | script: 28 | - cabal configure --enable-tests --enable-benchmarks -v2 29 | - cabal build 30 | - cabal test 31 | - cabal check 32 | - cabal sdist 33 | - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && 34 | (cd dist && cabal install --force-reinstalls "$SRC_TGZ") 35 | -------------------------------------------------------------------------------- /Changelog.markdown: -------------------------------------------------------------------------------- 1 | # Changelog 2 | 3 | ## 0.1.15.0 4 | * Bumped dependencies 5 | 6 | ## 0.1.14.0 7 | * Bumped dependencies 8 | 9 | ## 0.1.13.1 10 | * Bumped dependencies 11 | 12 | ## 0.1.13.0 13 | * Bumped dependencies 14 | 15 | ## 0.1.12.0 16 | * Support for GHC 8.4 17 | 18 | ## 0.1.11.0 19 | * Improved documentation 20 | * Fixed exists_table 21 | 22 | ## 0.1.10.1 23 | * Fixed hackage warnings 24 | 25 | ## 0.1.10.0 26 | * Relaxed time bounds 27 | 28 | ## 0.1.9.0 29 | * Bumped dependencies 30 | 31 | ## 0.1.8.0 32 | * Added MigrationCommands allowing sequencing of migrations in the Haskell API 33 | * Derived more datatypes for MigrationResult 34 | * Bumped dependencies 35 | 36 | ## 0.1.7.0 37 | * Propagate migration and validation result to application exit code 38 | 39 | ## 0.1.6.0 40 | * Support for GHC 8 41 | 42 | ## 0.1.5.0 43 | * Bumped dependencies 44 | 45 | ## 0.1.4.0 46 | * Improved error logging in standalone binary 47 | 48 | ## 0.1.3.0 49 | * Better transaction handling 50 | * Improved documentation 51 | 52 | ## 0.1.2.0 53 | * Moved Util module 54 | * Improved documentation 55 | 56 | ## 0.1.1.0 57 | * Support for schema validations. 58 | * Improved Haskell API 59 | 60 | ## 0.1.0.0 61 | * Support for file-based and Haskell migrations. 62 | -------------------------------------------------------------------------------- /License: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014, Andreas Meingast 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions 7 | are met: 8 | 9 | 1. Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | 2. Redistributions in binary form must reproduce the above copyright 13 | notice, this list of conditions and the following disclaimer in the 14 | documentation and/or other materials provided with the distribution. 15 | 16 | 3. Neither the name of the author nor the names of his contributors 17 | may be used to endorse or promote products derived from this software 18 | without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS 21 | OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 22 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 24 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 26 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 27 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 28 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 29 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 30 | POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /Readme.markdown: -------------------------------------------------------------------------------- 1 | # PostgreSQL Migrations for Haskell 2 | 3 | [![Build Status](https://api.travis-ci.org/ameingast/postgresql-simple-migration.png)](https://travis-ci.org/ameingast/postgresql-simple-migration) 4 | 5 | Welcome to postgresql-simple-migrations, a tool for helping you with 6 | PostgreSQL schema migrations. 7 | 8 | This project is an open-source database migration tool. It favors simplicity 9 | over configuration. 10 | 11 | It is implemented in Haskell and uses the (excellent) postgresql-simple 12 | library to communicate with PostgreSQL. 13 | 14 | It comes in two flavors: a library that features an easy to use Haskell 15 | API and as a standalone application. 16 | 17 | Database migrations can be written in SQL (in this case PostgreSQL-sql) 18 | or in Haskell. 19 | 20 | ## Why? 21 | Database migrations should not be hard. They should be under version control 22 | and documented both in your production systems and in your project files. 23 | 24 | ## What? 25 | This library executes SQL/Haskell migration scripts and keeps track of their 26 | meta information. 27 | 28 | Scripts are be executed exactly once and any changes to scripts will cause 29 | a run-time error notifying you of a corrupted database. 30 | 31 | The meta information consists of: 32 | * an MD5 checksum of the executed script to make sure already existing 33 | scripts cannot be modified in your production system. 34 | * a time-stamp of the date of execution so you can easily track when a change 35 | happened. 36 | 37 | This library also supports migration validation so you can ensure (some) 38 | correctness before your application logic kicks in. 39 | 40 | ## How? 41 | This utility can be used in two ways: embedded in your Haskell program or as 42 | a standalone binary. 43 | 44 | ### Standalone 45 | The standalone program supports file-based migrations. To execute all SQL-files 46 | in a directory $BASE\_DIR, execute the following command to initialize the database 47 | in a first step. 48 | 49 | ```bash 50 | CON="host=$host dbname=$db user=$user password=$pw" 51 | ./dist/build/migrate/migrate init $CON 52 | ./dist/build/migrate/migrate migrate $CON $BASE_DIR 53 | ``` 54 | 55 | To validate already executed scripts, execute the following: 56 | ```bash 57 | CON="host=$host dbname=$db user=$user password=$pw" 58 | ./dist/build/migrate/migrate init $CON 59 | ./dist/build/migrate/migrate validate $CON $BASE_DIR 60 | ``` 61 | 62 | For more information about the PostgreSQL connection string, see: 63 | [libpq-connect](http://www.postgresql.org/docs/9.3/static/libpq-connect.html). 64 | 65 | ### Library 66 | The library supports more actions than the standalone program. 67 | 68 | Initializing the database: 69 | 70 | ```haskell 71 | main :: IO () 72 | main = do 73 | let url = "host=$host dbname=$db user=$user password=$pw" 74 | con <- connectPostgreSQL (BS8.pack url) 75 | withTransaction con $ runMigration $ 76 | MigrationContext MigrationInitialization True con 77 | ``` 78 | 79 | For file-based migrations, the following snippet can be used: 80 | 81 | ```haskell 82 | main :: IO () 83 | main = do 84 | let url = "host=$host dbname=$db user=$user password=$pw" 85 | let dir = "." 86 | con <- connectPostgreSQL (BS8.pack url) 87 | withTransaction con $ runMigration $ 88 | MigrationContext (MigrationDirectory dir) True con 89 | ``` 90 | 91 | To run Haskell-based migrations, use this: 92 | 93 | ```haskell 94 | main :: IO () 95 | main = do 96 | let url = "host=$host dbname=$db user=$user password=$pw" 97 | let name = "my script" 98 | let script = "create table users (email varchar not null)"; 99 | con <- connectPostgreSQL (BS8.pack url) 100 | withTransaction con $ runMigration $ 101 | MigrationContext (MigrationScript name script) True con 102 | ``` 103 | 104 | Validations wrap _MigrationCommands_. This means that you can re-use all 105 | MigrationCommands to perform a read-only validation of your migrations. 106 | 107 | To perform a validation on a directory-based migration, you can use the 108 | following code: 109 | 110 | ```haskell 111 | main :: IO () 112 | main = do 113 | let url = "host=$host dbname=$db user=$user password=$pw" 114 | con <- connectPostgreSQL (BS8.pack url) 115 | withTransaction con $ runMigration $ MigrationContext 116 | (MigrationValidation (MigrationDirectory dir)) True con 117 | ``` 118 | 119 | Database migrations should always be performed in a transactional context. 120 | 121 | The standalone binary takes care of proper transaction handling automatically. 122 | 123 | The library does not make any assumptions about the current transactional state 124 | of the system. This means that the caller of the library has to take care of 125 | opening/closing/rolling-back transactions. This way you can execute multiple 126 | migration-commands or validations in sequence while still staying in the 127 | transaction you opened. 128 | 129 | The tests make use of this. After executing all migration-tests, the 130 | transaction is rolled back. 131 | 132 | ## Compilation and Tests 133 | The program is built with the _cabal_ build system. The following command 134 | builds the library, the standalone binary and the test package. 135 | 136 | ```bash 137 | cabal configure --enable-tests && cabal build -j 138 | ``` 139 | 140 | To execute the tests, you need a running PostgreSQL server with an empty 141 | database called _test_. Tests are executed through cabal as follows: 142 | 143 | ```bash 144 | cabal configure --enable-tests && cabal test 145 | ``` 146 | 147 | To build the project in a cabal sandbox, use the following code: 148 | 149 | ```bash 150 | cabal sandbox init 151 | cabal install -j --only-dependencies --enable-tests --disable-documentation 152 | cabal configure --enable-tests 153 | cabal test 154 | ``` 155 | 156 | To remove the generated cabal sandbox, use: 157 | ```bash 158 | cabal sandbox delete 159 | ``` 160 | 161 | ## To Do 162 | * Collect executed scripts and check if already executed scripts have been 163 | deleted. 164 | -------------------------------------------------------------------------------- /Setup.lhs: -------------------------------------------------------------------------------- 1 | > import Distribution.Simple 2 | > main = defaultMain 3 | -------------------------------------------------------------------------------- /postgresql-simple-migration.cabal: -------------------------------------------------------------------------------- 1 | name: postgresql-simple-migration 2 | version: 0.1.15.0 3 | synopsis: PostgreSQL Schema Migrations 4 | homepage: https://github.com/ameingast/postgresql-simple-migration 5 | Bug-reports: https://github.com/ameingast/postgresql-simple-migration/issues 6 | license: BSD3 7 | license-file: License 8 | author: Andreas Meingast 9 | maintainer: Andreas Meingast 10 | copyright: 2014-2016, Andreas Meingast 11 | category: Database 12 | build-type: Simple 13 | cabal-version: >= 1.10 14 | description: A PostgreSQL-simple schema migration utility 15 | 16 | extra-source-files: License 17 | Readme.markdown 18 | Changelog.markdown 19 | 20 | src/*.hs 21 | src/Database/PostgreSQL/Simple/*.hs 22 | 23 | test/*.hs 24 | test/Database/PostgreSQL/Simple/*.hs 25 | 26 | share/test/*.sql 27 | share/test/scripts/*.sql 28 | 29 | source-repository head 30 | type: git 31 | location: git://github.com/ameingast/postgresql-simple-migration 32 | 33 | Library 34 | exposed-modules: Database.PostgreSQL.Simple.Migration 35 | Database.PostgreSQL.Simple.Util 36 | hs-source-dirs: src 37 | ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns 38 | default-extensions: OverloadedStrings, CPP, LambdaCase 39 | default-language: Haskell2010 40 | build-depends: base >= 4.6 && < 5.0, 41 | base64-bytestring >= 1.0 && < 1.1, 42 | bytestring >= 0.10 && < 0.11, 43 | cryptohash >= 0.11 && < 0.12, 44 | directory >= 1.2 && < 1.4, 45 | postgresql-simple >= 0.4 && < 0.7, 46 | time >= 1.4 && < 1.10 47 | 48 | Executable migrate 49 | main-is: Main.hs 50 | hs-source-dirs: src 51 | ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns 52 | default-extensions: OverloadedStrings, CPP, LambdaCase 53 | default-language: Haskell2010 54 | build-depends: base >= 4.6 && < 5.0, 55 | base64-bytestring >= 1.0 && < 1.1, 56 | bytestring >= 0.10 && < 0.11, 57 | cryptohash >= 0.11 && < 0.12, 58 | directory >= 1.2 && < 1.4, 59 | postgresql-simple >= 0.4 && < 0.7, 60 | time >= 1.4 && < 1.10, 61 | text >= 1.2 && < 1.3 62 | 63 | test-suite tests 64 | main-is: Main.hs 65 | hs-source-dirs: test 66 | other-modules: Database.PostgreSQL.Simple.MigrationTest 67 | ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns 68 | default-extensions: OverloadedStrings, CPP, LambdaCase 69 | default-language: Haskell2010 70 | type: exitcode-stdio-1.0 71 | build-depends: base >= 4.6 && < 5.0, 72 | bytestring >= 0.10 && < 0.11, 73 | postgresql-simple >= 0.4 && < 0.7, 74 | hspec >= 2.2 && < 2.8, 75 | postgresql-simple-migration 76 | -------------------------------------------------------------------------------- /share/test/script.sql: -------------------------------------------------------------------------------- 1 | create table t3 (c3 varchar); 2 | -------------------------------------------------------------------------------- /share/test/scripts/1.sql: -------------------------------------------------------------------------------- 1 | create table t2 (c2 varchar); 2 | -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Simple/Migration.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Database.PostgreSQL.Simple.Migration 3 | -- Copyright : (c) 2014 Andreas Meingast 4 | -- 5 | -- License : BSD-style 6 | -- Maintainer : ameingast@gmail.com 7 | -- Stability : experimental 8 | -- Portability : GHC 9 | -- 10 | -- A migration library for postgresql-simple. 11 | -- 12 | -- For usage, see Readme.markdown. 13 | 14 | {-# LANGUAGE CPP #-} 15 | {-# LANGUAGE DeriveFoldable #-} 16 | {-# LANGUAGE DeriveFunctor #-} 17 | {-# LANGUAGE DeriveTraversable #-} 18 | {-# LANGUAGE LambdaCase #-} 19 | {-# LANGUAGE OverloadedStrings #-} 20 | {-# LANGUAGE NamedFieldPuns #-} 21 | 22 | module Database.PostgreSQL.Simple.Migration 23 | ( 24 | -- * Migration actions 25 | runMigration 26 | , runMigrations 27 | , sequenceMigrations 28 | 29 | -- * Migration types 30 | , MigrationContext(..) 31 | , MigrationCommand(..) 32 | , MigrationResult(..) 33 | , ScriptName 34 | , Checksum 35 | 36 | -- * Migration result actions 37 | , getMigrations 38 | 39 | -- * Migration result types 40 | , SchemaMigration(..) 41 | ) where 42 | 43 | #if __GLASGOW_HASKELL__ < 710 44 | import Control.Applicative ((<$>), (<*>)) 45 | #endif 46 | import Control.Monad (void, when) 47 | import qualified Crypto.Hash.MD5 as MD5 (hash) 48 | import qualified Data.ByteString as BS (ByteString, readFile) 49 | import qualified Data.ByteString.Base64 as B64 (encode) 50 | import Data.Foldable (Foldable) 51 | import Data.List (isPrefixOf, sort) 52 | import Data.Traversable (Traversable) 53 | #if __GLASGOW_HASKELL__ < 710 54 | import Data.Monoid (Monoid (..)) 55 | #endif 56 | import Data.Time (LocalTime) 57 | import Database.PostgreSQL.Simple (Connection, Only (..), 58 | execute, execute_, query, 59 | query_) 60 | import Database.PostgreSQL.Simple.FromRow (FromRow (..), field) 61 | import Database.PostgreSQL.Simple.ToField (ToField (..)) 62 | import Database.PostgreSQL.Simple.ToRow (ToRow (..)) 63 | import Database.PostgreSQL.Simple.Types (Query (..)) 64 | import Database.PostgreSQL.Simple.Util (existsTable) 65 | import System.Directory (getDirectoryContents) 66 | 67 | -- | Executes migrations inside the provided 'MigrationContext'. 68 | -- 69 | -- Returns 'MigrationSuccess' if the provided 'MigrationCommand' executes 70 | -- without error. If an error occurs, execution is stopped and 71 | -- a 'MigrationError' is returned. 72 | -- 73 | -- It is recommended to wrap 'runMigration' inside a database transaction. 74 | runMigration :: MigrationContext -> IO (MigrationResult String) 75 | runMigration (MigrationContext cmd verbose con) = case cmd of 76 | MigrationInitialization -> 77 | initializeSchema con verbose >> return MigrationSuccess 78 | MigrationDirectory path -> 79 | executeDirectoryMigration con verbose path 80 | MigrationScript name contents -> 81 | executeMigration con verbose name contents 82 | MigrationFile name path -> 83 | executeMigration con verbose name =<< BS.readFile path 84 | MigrationValidation validationCmd -> 85 | executeValidation con verbose validationCmd 86 | MigrationCommands commands -> 87 | runMigrations verbose con commands 88 | 89 | -- | Execute a sequence of migrations 90 | -- 91 | -- Returns 'MigrationSuccess' if all of the provided 'MigrationCommand's 92 | -- execute without error. If an error occurs, execution is stopped and the 93 | -- 'MigrationError' is returned. 94 | -- 95 | -- It is recommended to wrap 'runMigrations' inside a database transaction. 96 | runMigrations 97 | :: Bool 98 | -- ^ Run in verbose mode 99 | -> Connection 100 | -- ^ The postgres connection to use 101 | -> [MigrationCommand] 102 | -- ^ The commands to run 103 | -> IO (MigrationResult String) 104 | runMigrations verbose con commands = 105 | sequenceMigrations [runMigration (MigrationContext c verbose con) | c <- commands] 106 | 107 | -- | Run a sequence of contexts, stopping on the first failure 108 | sequenceMigrations :: Monad m => [m (MigrationResult e)] -> m (MigrationResult e) 109 | sequenceMigrations = \case 110 | [] -> return MigrationSuccess 111 | c:cs -> do 112 | r <- c 113 | case r of 114 | MigrationError s -> return (MigrationError s) 115 | MigrationSuccess -> sequenceMigrations cs 116 | 117 | -- | Executes all SQL-file based migrations located in the provided 'dir' 118 | -- in alphabetical order. 119 | executeDirectoryMigration :: Connection -> Bool -> FilePath -> IO (MigrationResult String) 120 | executeDirectoryMigration con verbose dir = 121 | scriptsInDirectory dir >>= go 122 | where 123 | go fs = sequenceMigrations (executeMigrationFile <$> fs) 124 | executeMigrationFile f = executeMigration con verbose f =<< BS.readFile (dir ++ "/" ++ f) 125 | 126 | -- | Lists all files in the given 'FilePath' 'dir' in alphabetical order. 127 | scriptsInDirectory :: FilePath -> IO [String] 128 | scriptsInDirectory dir = 129 | fmap (sort . filter (\x -> not $ "." `isPrefixOf` x)) 130 | (getDirectoryContents dir) 131 | 132 | -- | Executes a generic SQL migration for the provided script 'name' with 133 | -- content 'contents'. 134 | executeMigration :: Connection -> Bool -> ScriptName -> BS.ByteString -> IO (MigrationResult String) 135 | executeMigration con verbose name contents = do 136 | let checksum = md5Hash contents 137 | checkScript con name checksum >>= \case 138 | ScriptOk -> do 139 | when verbose $ putStrLn $ "Ok:\t" ++ name 140 | return MigrationSuccess 141 | ScriptNotExecuted -> do 142 | void $ execute_ con (Query contents) 143 | void $ execute con q (name, checksum) 144 | when verbose $ putStrLn $ "Execute:\t" ++ name 145 | return MigrationSuccess 146 | ScriptModified { actual, expected } -> do 147 | when verbose $ putStrLn 148 | $ "Fail:\t" ++ name 149 | ++ "\n" ++ scriptModifiedErrorMessage expected actual 150 | return (MigrationError name) 151 | where 152 | q = "insert into schema_migrations(filename, checksum) values(?, ?)" 153 | 154 | -- | Initializes the database schema with a helper table containing 155 | -- meta-information about executed migrations. 156 | initializeSchema :: Connection -> Bool -> IO () 157 | initializeSchema con verbose = do 158 | when verbose $ putStrLn "Initializing schema" 159 | void $ execute_ con $ mconcat 160 | [ "create table if not exists schema_migrations " 161 | , "( filename varchar(512) not null" 162 | , ", checksum varchar(32) not null" 163 | , ", executed_at timestamp without time zone not null default now() " 164 | , ");" 165 | ] 166 | 167 | -- | Validates a 'MigrationCommand'. Validation is defined as follows for these 168 | -- types: 169 | -- 170 | -- * 'MigrationInitialization': validate the presence of the meta-information 171 | -- table. 172 | -- * 'MigrationDirectory': validate the presence and checksum of all scripts 173 | -- found in the given directory. 174 | -- * 'MigrationScript': validate the presence and checksum of the given script. 175 | -- * 'MigrationFile': validate the presence and checksum of the given file. 176 | -- * 'MigrationValidation': always succeeds. 177 | -- * 'MigrationCommands': validates all the sub-commands stopping at the first failure. 178 | executeValidation :: Connection -> Bool -> MigrationCommand -> IO (MigrationResult String) 179 | executeValidation con verbose cmd = case cmd of 180 | MigrationInitialization -> 181 | existsTable con "schema_migrations" >>= \r -> return $ if r 182 | then MigrationSuccess 183 | else MigrationError "No such table: schema_migrations" 184 | MigrationDirectory path -> 185 | scriptsInDirectory path >>= goScripts path 186 | MigrationScript name contents -> 187 | validate name contents 188 | MigrationFile name path -> 189 | validate name =<< BS.readFile path 190 | MigrationValidation _ -> 191 | return MigrationSuccess 192 | MigrationCommands cs -> 193 | sequenceMigrations (executeValidation con verbose <$> cs) 194 | where 195 | validate name contents = 196 | checkScript con name (md5Hash contents) >>= \case 197 | ScriptOk -> do 198 | when verbose $ putStrLn $ "Ok:\t" ++ name 199 | return MigrationSuccess 200 | ScriptNotExecuted -> do 201 | when verbose $ putStrLn $ "Missing:\t" ++ name 202 | return (MigrationError $ "Missing: " ++ name) 203 | ScriptModified { expected, actual } -> do 204 | when verbose $ putStrLn 205 | $ "Checksum mismatch:\t" ++ name 206 | ++ "\n" ++ scriptModifiedErrorMessage expected actual 207 | return (MigrationError $ "Checksum mismatch: " ++ name) 208 | 209 | goScripts path xs = sequenceMigrations (goScript path <$> xs) 210 | goScript path x = validate x =<< BS.readFile (path ++ "/" ++ x) 211 | 212 | -- | Checks the status of the script with the given name 'name'. 213 | -- If the script has already been executed, the checksum of the script 214 | -- is compared against the one that was executed. 215 | -- If there is no matching script entry in the database, the script 216 | -- will be executed and its meta-information will be recorded. 217 | checkScript :: Connection -> ScriptName -> Checksum -> IO CheckScriptResult 218 | checkScript con name fileChecksum = 219 | query con q (Only name) >>= \case 220 | [] -> 221 | return ScriptNotExecuted 222 | Only dbChecksum:_ | fileChecksum == dbChecksum -> 223 | return ScriptOk 224 | Only dbChecksum:_ -> 225 | return (ScriptModified { 226 | expected = dbChecksum, 227 | actual = fileChecksum 228 | }) 229 | where 230 | q = mconcat 231 | [ "select checksum from schema_migrations " 232 | , "where filename = ? limit 1" 233 | ] 234 | 235 | -- | Calculates the MD5 checksum of the provided bytestring in base64 236 | -- encoding. 237 | md5Hash :: BS.ByteString -> Checksum 238 | md5Hash = B64.encode . MD5.hash 239 | 240 | -- | The checksum type of a migration script. 241 | type Checksum = BS.ByteString 242 | 243 | -- | The name of a script. Typically the filename or a custom name 244 | -- when using Haskell migrations. 245 | type ScriptName = String 246 | 247 | -- | 'MigrationCommand' determines the action of the 'runMigration' script. 248 | data MigrationCommand 249 | = MigrationInitialization 250 | -- ^ Initializes the database with a helper table containing meta 251 | -- information. 252 | | MigrationDirectory FilePath 253 | -- ^ Executes migrations based on SQL scripts in the provided 'FilePath' 254 | -- in alphabetical order. 255 | | MigrationFile ScriptName FilePath 256 | -- ^ Executes a migration based on script located at the provided 257 | -- 'FilePath'. 258 | | MigrationScript ScriptName BS.ByteString 259 | -- ^ Executes a migration based on the provided bytestring. 260 | | MigrationValidation MigrationCommand 261 | -- ^ Validates that the provided MigrationCommand has been executed. 262 | | MigrationCommands [MigrationCommand] 263 | -- ^ Performs a series of 'MigrationCommand's in sequence. 264 | deriving (Show, Eq, Read, Ord) 265 | 266 | #if __GLASGOW_HASKELL__ >= 804 267 | instance Semigroup MigrationCommand where 268 | (<>) = mappend 269 | #endif 270 | 271 | instance Monoid MigrationCommand where 272 | mempty = MigrationCommands [] 273 | mappend (MigrationCommands xs) (MigrationCommands ys) = MigrationCommands (xs ++ ys) 274 | mappend (MigrationCommands xs) y = MigrationCommands (xs ++ [y]) 275 | mappend x (MigrationCommands ys) = MigrationCommands (x : ys) 276 | mappend x y = MigrationCommands [x, y] 277 | 278 | -- | A sum-type denoting the result of a single migration. 279 | data CheckScriptResult 280 | = ScriptOk 281 | -- ^ The script has already been executed and the checksums match. 282 | -- This is good. 283 | | ScriptModified { expected :: Checksum, actual :: Checksum } 284 | -- ^ The script has already been executed and there is a checksum 285 | -- mismatch. This is bad. 286 | | ScriptNotExecuted 287 | -- ^ The script has not been executed, yet. This is good. 288 | deriving (Show, Eq, Read, Ord) 289 | 290 | scriptModifiedErrorMessage :: Checksum -> Checksum -> [Char] 291 | scriptModifiedErrorMessage expected actual = 292 | "expected: " ++ show expected ++ "\nhash was: " ++ show actual 293 | 294 | -- | A sum-type denoting the result of a migration. 295 | data MigrationResult a 296 | = MigrationError a 297 | -- ^ There was an error in script migration. 298 | | MigrationSuccess 299 | -- ^ All scripts have been executed successfully. 300 | deriving (Show, Eq, Read, Ord, Functor, Foldable, Traversable) 301 | 302 | -- | The 'MigrationContext' provides an execution context for migrations. 303 | data MigrationContext = MigrationContext 304 | { migrationContextCommand :: MigrationCommand 305 | -- ^ The action that will be performed by 'runMigration' 306 | , migrationContextVerbose :: Bool 307 | -- ^ Verbosity of the library. 308 | , migrationContextConnection :: Connection 309 | -- ^ The PostgreSQL connection to use for migrations. 310 | } 311 | 312 | -- | Produces a list of all executed 'SchemaMigration's. 313 | getMigrations :: Connection -> IO [SchemaMigration] 314 | getMigrations = flip query_ q 315 | where q = mconcat 316 | [ "select filename, checksum, executed_at " 317 | , "from schema_migrations order by executed_at asc" 318 | ] 319 | 320 | -- | A product type representing a single, executed 'SchemaMigration'. 321 | data SchemaMigration = SchemaMigration 322 | { schemaMigrationName :: BS.ByteString 323 | -- ^ The name of the executed migration. 324 | , schemaMigrationChecksum :: Checksum 325 | -- ^ The calculated MD5 checksum of the executed script. 326 | , schemaMigrationExecutedAt :: LocalTime 327 | -- ^ A timestamp without timezone of the date of execution of the script. 328 | } deriving (Show, Eq, Read) 329 | 330 | instance Ord SchemaMigration where 331 | compare (SchemaMigration nameLeft _ _) (SchemaMigration nameRight _ _) = 332 | compare nameLeft nameRight 333 | 334 | instance FromRow SchemaMigration where 335 | fromRow = SchemaMigration <$> 336 | field <*> field <*> field 337 | 338 | instance ToRow SchemaMigration where 339 | toRow (SchemaMigration name checksum executedAt) = 340 | [toField name, toField checksum, toField executedAt] 341 | -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Simple/Util.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Database.PostgreSQL.Simple.Util 3 | -- Copyright : (c) 2014 Andreas Meingast 4 | -- 5 | -- License : BSD-style 6 | -- Maintainer : ameingast@gmail.com 7 | -- Stability : experimental 8 | -- Portability : GHC 9 | -- 10 | -- A collection of utilites for database migrations. 11 | 12 | {-# LANGUAGE CPP #-} 13 | {-# LANGUAGE LambdaCase #-} 14 | {-# LANGUAGE OverloadedStrings #-} 15 | 16 | module Database.PostgreSQL.Simple.Util 17 | ( existsTable 18 | , withTransactionRolledBack 19 | ) where 20 | 21 | import Control.Exception (finally) 22 | import Database.PostgreSQL.Simple (Connection, Only (..), begin, 23 | query, rollback) 24 | import GHC.Int (Int64) 25 | 26 | -- | Checks if the table with the given name exists in the database. 27 | existsTable :: Connection -> String -> IO Bool 28 | existsTable con table = 29 | fmap checkRowCount (query con q (Only table) :: IO [[Int64]]) 30 | where 31 | q = "select count(relname) from pg_class where relname = ?" 32 | 33 | checkRowCount :: [[Int64]] -> Bool 34 | checkRowCount ((1:_):_) = True 35 | checkRowCount _ = False 36 | 37 | -- | Executes the given IO monad inside a transaction and performs a roll-back 38 | -- afterwards (even if exceptions occur). 39 | withTransactionRolledBack :: Connection -> IO a -> IO a 40 | withTransactionRolledBack con f = 41 | begin con >> finally f (rollback con) 42 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Main 3 | -- Copyright : (c) 2014 Andreas Meingast 4 | -- 5 | -- License : BSD-style 6 | -- Maintainer : ameingast@gmail.com 7 | -- Stability : experimental 8 | -- Portability : GHC 9 | -- 10 | -- A standalone program for the postgresql-simple-migration library. 11 | 12 | {-# LANGUAGE CPP #-} 13 | {-# LANGUAGE LambdaCase #-} 14 | {-# LANGUAGE OverloadedStrings #-} 15 | 16 | module Main ( 17 | main 18 | ) where 19 | 20 | #if __GLASGOW_HASKELL__ < 710 21 | import Control.Applicative 22 | #endif 23 | import Control.Exception 24 | import qualified Data.ByteString.Char8 as BS8 (pack) 25 | import Database.PostgreSQL.Simple (SqlError (..), 26 | connectPostgreSQL, 27 | withTransaction) 28 | import Database.PostgreSQL.Simple.Migration (MigrationCommand (..), 29 | MigrationContext (..), 30 | MigrationResult (..), 31 | runMigration) 32 | import System.Environment (getArgs) 33 | import System.Exit (exitFailure, exitSuccess) 34 | 35 | import qualified Data.Text as T 36 | import qualified Data.Text.Encoding as T 37 | 38 | main :: IO () 39 | main = getArgs >>= \case 40 | "-h":_ -> 41 | printUsage 42 | "-q":xs -> 43 | ppException $ run (parseCommand xs) False 44 | xs -> 45 | ppException $ run (parseCommand xs) True 46 | 47 | -- | Pretty print postgresql-simple exceptions to see whats going on 48 | ppException :: IO a -> IO a 49 | ppException a = catch a ehandler 50 | where 51 | ehandler e = maybe (throw e) (*> exitFailure) 52 | (pSqlError <$> fromException e) 53 | bsToString = T.unpack . T.decodeUtf8 54 | pSqlError e = mapM_ putStrLn 55 | [ "SqlError:" 56 | , " sqlState: " 57 | , bsToString $ sqlState e 58 | , " sqlExecStatus: " 59 | , show $ sqlExecStatus e 60 | , " sqlErrorMsg: " 61 | , bsToString $ sqlErrorMsg e 62 | , " sqlErrorDetail: " 63 | , bsToString $ sqlErrorDetail e 64 | , " sqlErrorHint: " 65 | , bsToString $ sqlErrorHint e 66 | ] 67 | 68 | run :: Maybe Command -> Bool-> IO () 69 | run Nothing _ = printUsage >> exitFailure 70 | run (Just cmd) verbose = 71 | handleResult =<< case cmd of 72 | Initialize url -> do 73 | con <- connectPostgreSQL (BS8.pack url) 74 | withTransaction con $ runMigration $ MigrationContext 75 | MigrationInitialization verbose con 76 | Migrate url dir -> do 77 | con <- connectPostgreSQL (BS8.pack url) 78 | withTransaction con $ runMigration $ MigrationContext 79 | (MigrationDirectory dir) verbose con 80 | Validate url dir -> do 81 | con <- connectPostgreSQL (BS8.pack url) 82 | withTransaction con $ runMigration $ MigrationContext 83 | (MigrationValidation (MigrationDirectory dir)) verbose con 84 | where 85 | handleResult MigrationSuccess = exitSuccess 86 | handleResult (MigrationError _) = exitFailure 87 | 88 | parseCommand :: [String] -> Maybe Command 89 | parseCommand ("init":url:_) = Just (Initialize url) 90 | parseCommand ("migrate":url:dir:_) = Just (Migrate url dir) 91 | parseCommand ("validate":url:dir:_) = Just (Validate url dir) 92 | parseCommand _ = Nothing 93 | 94 | printUsage :: IO () 95 | printUsage = do 96 | putStrLn "migrate [options] " 97 | putStrLn " Options:" 98 | putStrLn " -h Print help text" 99 | putStrLn " -q Enable quiet mode" 100 | putStrLn " Commands:" 101 | putStrLn " init " 102 | putStrLn " Initialize the database. Required to be run" 103 | putStrLn " at least once." 104 | putStrLn " migrate " 105 | putStrLn " Execute all SQL scripts in the provided" 106 | putStrLn " directory in alphabetical order." 107 | putStrLn " Scripts that have already been executed are" 108 | putStrLn " ignored. If a script was changed since the" 109 | putStrLn " time of its last execution, an error is" 110 | putStrLn " raised." 111 | putStrLn " validate " 112 | putStrLn " Validate all SQL scripts in the provided" 113 | putStrLn " directory." 114 | putStrLn " The parameter is based on libpq connection string" 115 | putStrLn " syntax. Detailled information is available here:" 116 | putStrLn " " 117 | 118 | data Command 119 | = Initialize String 120 | | Migrate String FilePath 121 | | Validate String FilePath 122 | deriving (Show, Eq, Read, Ord) 123 | -------------------------------------------------------------------------------- /test/Database/PostgreSQL/Simple/MigrationTest.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Database.PostgreSQL.Simple.MigrationTest 3 | -- Copyright : (c) 2014 Andreas Meingast 4 | -- 5 | -- License : BSD-style 6 | -- Maintainer : ameingast@gmail.com 7 | -- Stability : experimental 8 | -- Portability : GHC 9 | -- 10 | -- A collection of postgresql-simple-migration specifications. 11 | 12 | {-# LANGUAGE CPP #-} 13 | {-# LANGUAGE LambdaCase #-} 14 | {-# LANGUAGE OverloadedStrings #-} 15 | 16 | module Database.PostgreSQL.Simple.MigrationTest where 17 | 18 | import Database.PostgreSQL.Simple (Connection) 19 | import Database.PostgreSQL.Simple.Migration (MigrationCommand (..), 20 | MigrationContext (..), 21 | MigrationResult (..), 22 | SchemaMigration (..), 23 | getMigrations, 24 | runMigration) 25 | import Database.PostgreSQL.Simple.Util (existsTable) 26 | import Test.Hspec (Spec, describe, it, 27 | shouldBe) 28 | 29 | migrationSpec:: Connection -> Spec 30 | migrationSpec con = describe "Migrations" $ do 31 | let migrationScript = MigrationScript "test.sql" q 32 | let migrationScriptAltered = MigrationScript "test.sql" "" 33 | let migrationDir = MigrationDirectory "share/test/scripts" 34 | let migrationFile = MigrationFile "s.sql" "share/test/script.sql" 35 | 36 | it "asserts that the schema_migrations table does not exist" $ do 37 | r <- existsTable con "schema_migrations" 38 | r `shouldBe` False 39 | 40 | it "validates an initialization on an empty database" $ do 41 | r <- runMigration $ MigrationContext 42 | (MigrationValidation MigrationInitialization) False con 43 | r `shouldBe` MigrationError "No such table: schema_migrations" 44 | 45 | it "initializes a database" $ do 46 | r <- runMigration $ MigrationContext MigrationInitialization False con 47 | r `shouldBe` MigrationSuccess 48 | 49 | it "creates the schema_migrations table" $ do 50 | r <- existsTable con "schema_migrations" 51 | r `shouldBe` True 52 | 53 | it "executes a migration script" $ do 54 | r <- runMigration $ MigrationContext migrationScript False con 55 | r `shouldBe` MigrationSuccess 56 | 57 | it "creates the table from the executed script" $ do 58 | r <- existsTable con "t1" 59 | r `shouldBe` True 60 | 61 | it "skips execution of the same migration script" $ do 62 | r <- runMigration $ 63 | MigrationContext migrationScript False con 64 | r `shouldBe` MigrationSuccess 65 | 66 | it "reports an error on a different checksum for the same script" $ do 67 | r <- runMigration $ MigrationContext migrationScriptAltered False con 68 | r `shouldBe` MigrationError "test.sql" 69 | 70 | it "executes migration scripts inside a folder" $ do 71 | r <- runMigration $ MigrationContext migrationDir False con 72 | r `shouldBe` MigrationSuccess 73 | 74 | it "creates the table from the executed scripts" $ do 75 | r <- existsTable con "t2" 76 | r `shouldBe` True 77 | 78 | it "executes a file based migration script" $ do 79 | r <- runMigration $ MigrationContext migrationFile False con 80 | r `shouldBe` MigrationSuccess 81 | 82 | it "creates the table from the executed scripts" $ do 83 | r <- existsTable con "t3" 84 | r `shouldBe` True 85 | 86 | it "validates initialization" $ do 87 | r <- runMigration $ MigrationContext 88 | (MigrationValidation MigrationInitialization) False con 89 | r `shouldBe` MigrationSuccess 90 | 91 | it "validates an executed migration script" $ do 92 | r <- runMigration $ MigrationContext 93 | (MigrationValidation migrationScript) False con 94 | r `shouldBe` MigrationSuccess 95 | 96 | it "validates all scripts inside a folder" $ do 97 | r <- runMigration $ MigrationContext 98 | (MigrationValidation migrationDir) False con 99 | r `shouldBe` MigrationSuccess 100 | 101 | it "validates an executed migration file" $ do 102 | r <- runMigration $ MigrationContext 103 | (MigrationValidation migrationFile) False con 104 | r `shouldBe` MigrationSuccess 105 | 106 | it "gets a list of executed migrations" $ do 107 | r <- getMigrations con 108 | map schemaMigrationName r `shouldBe` ["test.sql", "1.sql", "s.sql"] 109 | 110 | where 111 | q = "create table t1 (c1 varchar);" 112 | 113 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module : Main 3 | -- Copyright : (c) 2014 Andreas Meingast 4 | -- 5 | -- License : BSD-style 6 | -- Maintainer : ameingast@gmail.com 7 | -- Stability : experimental 8 | -- Portability : GHC 9 | -- 10 | -- The test entry-point for postgresql-simple-migration. 11 | 12 | {-# LANGUAGE CPP #-} 13 | {-# LANGUAGE LambdaCase #-} 14 | {-# LANGUAGE OverloadedStrings #-} 15 | 16 | module Main 17 | ( main 18 | ) where 19 | 20 | import Database.PostgreSQL.Simple (connectPostgreSQL) 21 | import Database.PostgreSQL.Simple.MigrationTest (migrationSpec) 22 | import Database.PostgreSQL.Simple.Util (withTransactionRolledBack) 23 | import Test.Hspec (hspec) 24 | 25 | main :: IO () 26 | main = do 27 | con <- connectPostgreSQL "dbname=test" 28 | withTransactionRolledBack con (hspec (migrationSpec con)) 29 | --------------------------------------------------------------------------------