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,109 @@ +# PostgreSQL Migrations for Haskell + +[![Build Status](https://api.travis-ci.org/ameingast/postgresql-simple-migration.png)](https://travis-ci.org/ameingast/postgresql-simple-migration) + +Welcome to postgresql-simple-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 in both 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. + +## 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" +./dist/build/migrate/migrate init $CON +./dist/build/migrate/migrate migrate $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) + void $ runMigration $ MigrationContext MigrationInitialization True con +``` + +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) + void $ runMigration $ MigrationContext (MigrationDirectory dir) True con +``` + +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) + void $ runMigration $ MigrationContext (MigrationScript name script) True con +``` + +## Compilation and Tests +The program is built with the _cabal_ build system. The following command +builds the library, the standalone binary and the test package. + +```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 Do +* Collect executed scripts and check if already executed scripts have been + deleted. +* Validate command for the standalone program. 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/postgresql-simple-migration.cabal b/postgresql-simple-migration.cabal new file mode 100644 --- /dev/null +++ b/postgresql-simple-migration.cabal @@ -0,0 +1,69 @@ +name: postgresql-simple-migration +version: 0.1.0.0 +synopsis: PostgreSQL Schema Migrations +homepage: https://github.com/ameingast/postgresql-simple-migration +Bug-reports: https://github.com/ameingast/postgresql-simple-migration/issues +license: BSD3 +license-file: License +author: Andreas Meingast +maintainer: Andreas Meingast +copyright: 2014, Andreas Meingast +category: Database +build-type: Simple +cabal-version: >= 1.10 +description: A PostgreSQL-simple schema migration utility + +extra-source-files: License + Readme.markdown + + src/*.hs + src/Database/PostgreSQL/Simple/*.hs + + test/*.hs + test/Database/PostgreSQL/Simple/*.hs + + share/test/*.sql + share/test/scripts/*.sql + +source-repository head + type: git + location: git://github.com/ameingast/postgresql-simple-migration + +Library + exposed-modules: Database.PostgreSQL.Simple.Migration + hs-source-dirs: src + ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns + default-extensions: OverloadedStrings + default-language: Haskell2010 + build-depends: base >= 4.6 && < 5.0, + base64-bytestring >= 1.0 && < 1.1, + bytestring >= 0.10 && < 0.11, + cryptohash >= 0.11 && < 0.12, + directory >= 1.2 && < 1.3, + postgresql-simple >= 0.4 && < 0.5 + +Executable migrate + main-is: Main.hs + hs-source-dirs: src + ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns + default-extensions: OverloadedStrings + default-language: Haskell2010 + build-depends: base >= 4.6 && < 5.0, + base64-bytestring >= 1.0 && < 1.1, + bytestring >= 0.10 && < 0.11, + cryptohash >= 0.11 && < 0.12, + directory >= 1.2 && < 1.3, + postgresql-simple >= 0.4 && < 0.5 + +test-suite tests + main-is: Main.hs + hs-source-dirs: test + ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns + default-extensions: OverloadedStrings + default-language: Haskell2010 + type: exitcode-stdio-1.0 + build-depends: base >= 4.6 && < 5.0, + bytestring >= 0.10 && < 0.11, + postgresql-simple >= 0.4 && < 0.5, + hspec >= 1.10 && < 1.11, + postgresql-simple-migration >= 0.1 && < 0.2 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,166 @@ +-- | +-- Module : Database.PostgreSQL.Simple.Migration +-- Copyright : (c) 2014 Andreas Meingast +-- +-- License : BSD-style +-- Maintainer : ameingast@gmail.com +-- Stability : experimental +-- Portability : GHC +-- +-- Migration library for postgresql-simple. + +module Database.PostgreSQL.Simple.Migration + ( runMigration + , MigrationContext(..) + , MigrationCommand(..) + , MigrationResult(..) + , ScriptName + ) where + +import Control.Monad (liftM, void, when) +import qualified Crypto.Hash.MD5 as MD5 (hash) +import qualified Data.ByteString as BS (ByteString, readFile) +import qualified Data.ByteString.Base64 as B64 (encode) +import Data.List (isPrefixOf, sort) +import Data.Monoid (mconcat) +import Database.PostgreSQL.Simple (Connection, Only (..), + execute, execute_, query) +import Database.PostgreSQL.Simple.Types (Query (..)) +import System.Directory (getDirectoryContents) + +-- | Executes migrations inside the provided 'MigrationContext'. +runMigration :: MigrationContext -> IO (MigrationResult String) +runMigration (MigrationContext cmd verbose con) = case cmd of + MigrationInitialization -> + initializeSchema con verbose >> return MigrationSuccess + MigrationDirectory path -> + executeDirectoryMigration con verbose path + MigrationScript name contents -> + executeMigration con verbose name contents + MigrationFile name path -> + executeMigration con verbose name =<< BS.readFile path + +-- | Executes all SQL-file based migrations located in the provided 'dir'. +executeDirectoryMigration :: Connection -> Bool -> FilePath -> IO (MigrationResult String) +executeDirectoryMigration con verbose dir = + liftM (filter (\x -> not $ "." `isPrefixOf` x)) + (getDirectoryContents dir) >>= go . sort + where + go [] = return MigrationSuccess + go (f:fs) = do + r <- executeMigration con verbose f =<< BS.readFile (dir ++ "/" ++ f) + case r of + MigrationError _ -> + return r + MigrationSuccess -> + go fs + +-- | Executes a generic SQL migration for the provided script 'name' with +-- content 'contents'. +executeMigration :: Connection -> Bool -> ScriptName -> BS.ByteString -> IO (MigrationResult String) +executeMigration con verbose name contents = do + let checksum = md5Hash contents + checkScript con name checksum >>= \r -> case r of + ScriptOk -> do + when verbose $ putStrLn $ "Ok:\t" ++ name + return MigrationSuccess + ScriptNotExecuted -> do + void $ execute_ con (Query contents) + void $ execute con q (name, checksum) + when verbose $ putStrLn $ "Execute:\t" ++ name + return MigrationSuccess + ScriptModified _ -> do + when verbose $ putStrLn $ "Fail:\t" ++ name + return (MigrationError name) + where + q = "insert into schema_migrations(filename, checksum) values(?, ?) " + +-- | Initializes the database schema with a helper table containing +-- meta-information about executed migrations. +initializeSchema :: Connection -> Bool -> IO () +initializeSchema con verbose = do + when verbose $ putStrLn "Initializing schema" + void $ execute_ con $ mconcat + [ "create table if not exists schema_migrations " + , "( filename varchar(512) not null" + , ", checksum varchar(32) not null" + , ", executed_at timestamp without time zone not null default now() " + , ");" + ] + +-- | 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 -> ScriptName -> Checksum -> IO CheckScriptResult +checkScript con name checksum = + query con q (Only name) >>= \r -> case r of + [] -> + return ScriptNotExecuted + Only actualChecksum:_ | checksum == actualChecksum -> + return ScriptOk + Only actualChecksum:_ -> + return (ScriptModified actualChecksum) + where + q = mconcat + [ "select checksum from schema_migrations " + , "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. + deriving (Show, Eq, Read, Ord) + +-- | 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 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, Eq, Read, Ord) + +-- | 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) + +-- | The 'MigrationContext' provides an execution context for migrations. +data MigrationContext = MigrationContext + { migrationContextCommand :: 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/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,63 @@ +module Main ( + main + ) where + +import Control.Monad (void) +import qualified Data.ByteString.Char8 as BS8 (pack) +import Database.PostgreSQL.Simple (connectPostgreSQL) +import Database.PostgreSQL.Simple.Migration (MigrationCommand (..), + MigrationContext (..), + runMigration) +import System.Environment (getArgs) +import System.Exit (exitFailure) + +main :: IO () +main = getArgs >>= \args -> case args of + "-h":_ -> + printUsage + "-q":xs -> + run (parseCommand xs) False + xs -> + run (parseCommand xs) True + +run :: Maybe Command -> Bool-> IO () +run Nothing _ = printUsage >> exitFailure +run (Just cmd) verbose = + void $ case cmd of + Initialize url -> do + con <- connectPostgreSQL (BS8.pack url) + runMigration $ MigrationContext MigrationInitialization verbose con + Migrate url dir -> do + con <- connectPostgreSQL (BS8.pack url) + runMigration $ MigrationContext (MigrationDirectory dir) verbose con + +parseCommand :: [String] -> Maybe Command +parseCommand ("init":url:_) = Just (Initialize url) +parseCommand ("migrate":url:dir:_) = Just (Migrate url dir) +parseCommand _ = Nothing + +printUsage :: IO () +printUsage = do + putStrLn "migrate [options] " + putStrLn " Options:" + putStrLn " -h Print help text" + putStrLn " -q Enable quiet mode" + putStrLn " Commands:" + putStrLn " init " + putStrLn " Initialize the database. Required to be run" + putStrLn " at least once." + putStrLn " migrate " + putStrLn " Execute all SQL scripts in the provided" + putStrLn " directory in alphabetical order." + putStrLn " Scripts that have already been executed are" + putStrLn " ignored. If a script was changed since the" + putStrLn " time of its last execution, an error is" + putStrLn " raised." + putStrLn " The parameter is based on libpq connection string" + putStrLn " syntax. Detailled information is available here:" + putStrLn " " + +data Command + = Initialize String + | Migrate String String + deriving (Show, Eq, Read, Ord) 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,69 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Database.PostgreSQL.Simple.MigrationTest where + +import Control.Monad (liftM) +import Database.PostgreSQL.Simple (Connection, Only (..), + query) +import Database.PostgreSQL.Simple.Migration (MigrationCommand (..), + MigrationContext (..), + MigrationResult (..), + runMigration) +import Test.Hspec (Spec, describe, it, + shouldBe) + +migrationSpec:: Connection -> Spec +migrationSpec con = describe "runMigration" $ do + it "initializes a database" $ do + r <- runMigration $ + MigrationContext MigrationInitialization False con + r `shouldBe` MigrationSuccess + + it "creates the schema_migration table" $ do + r <- existsTable con "schema_migration" + r `shouldBe` True + + it "executes a migration script" $ do + r <- runMigration $ + MigrationContext (MigrationScript "test.sql" q) 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 "test.sql" q) False con + r `shouldBe` MigrationSuccess + + it "reports an error on a different checksum for the same script" $ do + r <- runMigration $ + MigrationContext (MigrationScript "test.sql" "") False con + r `shouldBe` MigrationError "test.sql" + + it "executes migration scripts inside a folder" $ do + r <- runMigration $ + MigrationContext (MigrationDirectory "share/test/scripts") 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 "s.sql" "share/test/script.sql") False con + r `shouldBe` MigrationSuccess + + it "creates the table from the executed scripts" $ do + r <- existsTable con "t3" + r `shouldBe` True + where + q = "create table t1 (c1 varchar);" + +existsTable :: Connection -> String -> IO Bool +existsTable con table = + liftM (not . null) (query con q (Only table) :: IO [[Int]]) + where + q = "select count(relname) from pg_class where relname = ?" diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,20 @@ +module Main + ( main + ) where + +import Control.Exception (finally) +import Database.PostgreSQL.Simple (begin, + connectPostgreSQL, + rollback) +import Database.PostgreSQL.Simple.MigrationTest (migrationSpec) +import Test.Hspec (hspec) + +main :: IO () +main = do + con <- connectPostgreSQL "dbname=test" + begin con + finally + (hspec (migrationSpec con)) + (rollback con) + +