diff --git a/License b/License new file mode 100644 --- /dev/null +++ b/License @@ -0,0 +1,31 @@ +Copyright (c) 2014, Andreas Meingast +Copyright (c) 2016, Timo von Holtz + +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,64 @@ +# PostgreSQL Migrations for Haskell + +[![Build Status](https://api.travis-ci.org/tvh/hasql-migration.png)](https://travis-ci.org/tvh/hasql-migration) + +Welcome to hasql-migrations, a tool for helping you with +PostgreSQL schema migrations. This is a port of +[postgresql-simple-migration](https://github.com/ameingast/postgresql-simple-migration) +for use with hasql. + +## 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. + +This library also supports migration validation so you can ensure (some) +correctness before your application logic kicks in. + +## How? +TODO + +## 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 build the project in a cabal sandbox, use the following code: + +```bash +cabal sandbox init +cabal install -j --only-dependencies --enable-tests --disable-documentation +cabal configure --enable-tests +cabal test +``` + +To remove the generated cabal sandbox, use: +```bash +cabal sandbox delete +``` + +## To Do +* Collect executed scripts and check if already executed scripts have been + deleted. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hasql-migration.cabal b/hasql-migration.cabal new file mode 100644 --- /dev/null +++ b/hasql-migration.cabal @@ -0,0 +1,60 @@ +name: hasql-migration +version: 0.1.0 +synopsis: PostgreSQL Schema Migrations +homepage: https://github.com/tvh/hasql-migration +Bug-reports: https://github.com/tvh/hasql-migration/issues +license: BSD3 +license-file: License +author: Timo von Holtz +maintainer: Timo von Holtz +copyright: 2014-2016, Andreas Meingast + 2016, Timo von Holtz +category: Database +build-type: Simple +cabal-version: >= 1.10 +description: A PostgreSQL-simple schema migration utility + +extra-source-files: License + Readme.markdown + + test/*.hs + test/Hasql/*.hs + + share/test/*.sql + share/test/scripts/*.sql + +source-repository head + type: git + location: git://github.com/tvh/hasql-migration + +Library + exposed-modules: Hasql.Migration + Hasql.Migration.Util + hs-source-dirs: src + ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns + default-language: Haskell2010 + build-depends: base >= 4.7 && < 5.0, + base64-bytestring >= 1.0 && < 1.1, + bytestring >= 0.10 && < 0.11, + contravariant >= 1.3 && < 1.5, + cryptohash >= 0.11 && < 0.12, + data-default-class >= 0.0.1 && < 0.2, + directory >= 1.2 && < 1.3, + hasql >= 0.19 && < 0.20, + hasql-transaction >= 0.4 && < 0.5, + text >= 1.2 && < 1.3, + time >= 1.4 && < 1.7 + +test-suite tests + main-is: Main.hs + hs-source-dirs: test + ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns + default-language: Haskell2010 + type: exitcode-stdio-1.0 + build-depends: base >= 4.7 && < 5.0, + bytestring >= 0.10 && < 0.11, + hasql >= 0.19 && < 0.20, + hasql-migration, + hasql-transaction >= 0.4 && < 0.5, + hspec >= 2.2 && < 2.3, + transformers >= 0.3 && < 0.6 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/Hasql/Migration.hs b/src/Hasql/Migration.hs new file mode 100644 --- /dev/null +++ b/src/Hasql/Migration.hs @@ -0,0 +1,238 @@ +-- | +-- Module : Hasql..Migration +-- Copyright : (c) 2016 Timo von Holtz , +-- (c) 2014 Andreas Meingast +-- +-- License : BSD-style +-- Maintainer : tvh@tvholtz.de +-- Stability : experimental +-- Portability : GHC +-- +-- A migration library for hasql. + +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Hasql.Migration + ( + -- * Migration actions + runMigration + , loadMigrationFromFile + , loadMigrationsFromDirectory + + -- * Migration types + , MigrationCommand(..) + , MigrationResult(..) + , ScriptName + , Checksum + + -- * Migration result actions + , getMigrations + + -- * Migration result types + , SchemaMigration(..) + ) where + +import Control.Arrow +import Control.Applicative +import Data.Default.Class +import Data.Functor.Contravariant +import Data.List (isPrefixOf, sort) +import Data.Monoid +import Data.Traversable (forM) +import Data.Time (LocalTime) +import Hasql.Migration.Util (existsTable) +import Hasql.Query +import Hasql.Transaction +import System.Directory (getDirectoryContents) +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 qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Hasql.Decoders as Decoders +import qualified Hasql.Encoders as Encoders + +-- | Executes a 'MigrationCommand'. +-- +-- Returns 'MigrationSuccess' if the provided 'MigrationCommand' executes +-- without error. If an error occurs, execution is stopped and +-- a 'MigrationError' is returned. +runMigration :: MigrationCommand -> Transaction (MigrationResult String) +runMigration cmd = case cmd of + MigrationInitialization -> + initializeSchema >> return MigrationSuccess + MigrationScript name contents -> + executeMigration name contents + MigrationValidation validationCmd -> + executeValidation validationCmd + +-- | Load migrations from SQL scripts in the provided 'FilePath' +-- in alphabetical order. +loadMigrationsFromDirectory :: FilePath -> IO [MigrationCommand] +loadMigrationsFromDirectory dir = do + scripts <- scriptsInDirectory dir + forM scripts $ \f -> loadMigrationFromFile f (dir ++ "/" ++ f) + +-- | load a migration from script located at the provided +-- 'FilePath'. +loadMigrationFromFile :: ScriptName -> FilePath -> IO MigrationCommand +loadMigrationFromFile name fp = + MigrationScript name <$> BS.readFile fp + + +-- | Lists all files in the given 'FilePath' 'dir' in alphabetical order. +scriptsInDirectory :: FilePath -> IO [String] +scriptsInDirectory dir = + fmap (sort . filter (\x -> not $ "." `isPrefixOf` x)) + (getDirectoryContents dir) + +-- | Executes a generic SQL migration for the provided script 'name' with +-- content 'contents'. +executeMigration :: ScriptName -> BS.ByteString -> Transaction (MigrationResult String) +executeMigration name contents = do + let checksum = md5Hash contents + checkScript name checksum >>= \case + ScriptOk -> do + return MigrationSuccess + ScriptNotExecuted -> do + sql contents + query (name, checksum) (statement q (contramap (first T.pack) def) Decoders.unit False) + return MigrationSuccess + ScriptModified _ -> do + return (MigrationError name) + where + q = "insert into schema_migrations(filename, checksum) values($1, $2)" + +-- | Initializes the database schema with a helper table containing +-- meta-information about executed migrations. +initializeSchema :: Transaction () +initializeSchema = do + sql $ 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() " + , ");" + ] + +-- | Validates a 'MigrationCommand'. Validation is defined as follows for these +-- types: +-- +-- * 'MigrationInitialization': validate the presence of the meta-information +-- table. +-- * 'MigrationValidation': always succeeds. +executeValidation :: MigrationCommand -> Transaction (MigrationResult String) +executeValidation cmd = case cmd of + MigrationInitialization -> + existsTable "schema_migrations" >>= \r -> return $ if r + then MigrationSuccess + else MigrationError "No such table: schema_migrations" + MigrationScript name contents -> + validate name contents + MigrationValidation _ -> + return MigrationSuccess + where + validate name contents = + checkScript name (md5Hash contents) >>= \case + ScriptOk -> do + return MigrationSuccess + ScriptNotExecuted -> do + return (MigrationError $ "Missing: " ++ name) + ScriptModified _ -> do + return (MigrationError $ "Checksum mismatch: " ++ name) + +-- | 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 :: ScriptName -> Checksum -> Transaction CheckScriptResult +checkScript name checksum = + query name (statement q (contramap T.pack (Encoders.value def)) (Decoders.maybeRow (Decoders.value def)) False) >>= \case + Nothing -> + return ScriptNotExecuted + Just actualChecksum | checksum == actualChecksum -> + return ScriptOk + Just actualChecksum -> + return (ScriptModified actualChecksum) + where + q = mconcat + [ "select checksum from schema_migrations " + , "where filename = $1 limit 1" + ] + +-- | Calculates the MD5 checksum of the provided bytestring in base64 +-- encoding. +md5Hash :: BS.ByteString -> Checksum +md5Hash = T.decodeUtf8 . B64.encode . MD5.hash + +-- | The checksum type of a migration script. +type Checksum = T.Text + +-- | 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. + | MigrationScript ScriptName BS.ByteString + -- ^ Executes a migration based on the provided bytestring. + | MigrationValidation MigrationCommand + -- ^ Validates the provided MigrationCommand. + 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) + +-- | Produces a list of all executed 'SchemaMigration's. +getMigrations :: Transaction [SchemaMigration] +getMigrations = + query () $ statement q def (Decoders.rowsList decodeSchemaMigration) False + where + q = mconcat + [ "select filename, checksum, executed_at " + , "from schema_migrations 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 + +decodeSchemaMigration :: Decoders.Row SchemaMigration +decodeSchemaMigration = + SchemaMigration + <$> Decoders.value def + <*> Decoders.value def + <*> Decoders.value def diff --git a/src/Hasql/Migration/Util.hs b/src/Hasql/Migration/Util.hs new file mode 100644 --- /dev/null +++ b/src/Hasql/Migration/Util.hs @@ -0,0 +1,32 @@ +-- | +-- Module : Hasql.Migration.Util +-- Copyright : (c) 2016 Timo von Holtz , +-- (c) 2014-2016 Andreas Meingast +-- +-- License : BSD-style +-- Maintainer : tvh@tvholtz.de +-- Stability : experimental +-- Portability : GHC +-- +-- A collection of utilites for database migrations. + +{-# LANGUAGE OverloadedStrings #-} + +module Hasql.Migration.Util + ( existsTable + ) where + +import Hasql.Query +import qualified Hasql.Encoders as Encoders +import qualified Hasql.Decoders as Decoders +import Hasql.Transaction (query, Transaction) +import Data.Text (Text) +import Data.Default.Class + +-- | Checks if the table with the given name exists in the database. +existsTable :: Text -> Transaction Bool +existsTable table = + fmap (not . null) $ query table q + where + q = statement sql (Encoders.value def) (Decoders.rowsList (Decoders.value Decoders.int8)) False + sql = "select count(relname) from pg_class where relname = $1" diff --git a/test/Hasql/MigrationTest.hs b/test/Hasql/MigrationTest.hs new file mode 100644 --- /dev/null +++ b/test/Hasql/MigrationTest.hs @@ -0,0 +1,98 @@ +-- | +-- Module : Database.PostgreSQL.Simple.MigrationTest +-- Copyright : (c) 2016 Timo von Holtz , +-- (c) 2014 Andreas Meingast +-- +-- License : BSD-style +-- Maintainer : tvh@tvholtz.de +-- Stability : experimental +-- Portability : GHC +-- +-- A collection of hasql-migration specifications. + +{-# LANGUAGE OverloadedStrings #-} + +module Hasql.MigrationTest where + +import Hasql.Session (run, Error) +import Hasql.Connection +import qualified Hasql.Transaction as Tx +import Hasql.Migration +import Hasql.Migration.Util (existsTable) +import Test.Hspec (Spec, describe, it, + shouldBe, runIO) + +runTx :: Connection -> Tx.Transaction a -> IO (Either Error a) +runTx con act = do + run (Tx.run act Tx.ReadCommitted Tx.Write) con + +migrationSpec :: Connection -> Spec +migrationSpec con = describe "Migrations" $ do + let migrationScript = MigrationScript "test.sql" q + let migrationScriptAltered = MigrationScript "test.sql" "" + [migrationDir] <- runIO $ loadMigrationsFromDirectory "share/test/scripts" + migrationFile <- runIO $ loadMigrationFromFile "s.sql" "share/test/script.sql" + + it "initializes a database" $ do + r <- runTx con $ runMigration $ MigrationInitialization + r `shouldBe` Right MigrationSuccess + + it "creates the schema_migrations table" $ do + r <- runTx con $ existsTable "schema_migration" + r `shouldBe` Right True + + it "executes a migration script" $ do + r <- runTx con $ runMigration $ migrationScript + r `shouldBe` Right MigrationSuccess + + it "creates the table from the executed script" $ do + r <- runTx con $ existsTable "t1" + r `shouldBe` Right True + + it "skips execution of the same migration script" $ do + r <- runTx con $ runMigration $ migrationScript + r `shouldBe` Right MigrationSuccess + + it "reports an error on a different checksum for the same script" $ do + r <- runTx con $ runMigration $ migrationScriptAltered + r `shouldBe` Right (MigrationError "test.sql") + + it "executes migration scripts inside a folder" $ do + r <- runTx con $ runMigration $ migrationDir + r `shouldBe` Right MigrationSuccess + + it "creates the table from the executed scripts" $ do + r <- runTx con $ existsTable "t2" + r `shouldBe` Right True + + it "executes a file based migration script" $ do + r <- runTx con $ runMigration $ migrationFile + r `shouldBe` Right MigrationSuccess + + it "creates the table from the executed scripts" $ do + r <- runTx con $ existsTable "t3" + r `shouldBe` Right True + + it "validates initialization" $ do + r <- runTx con $ runMigration $ (MigrationValidation MigrationInitialization) + r `shouldBe` Right MigrationSuccess + + it "validates an executed migration script" $ do + r <- runTx con $ runMigration $ (MigrationValidation migrationScript) + r `shouldBe` Right MigrationSuccess + + it "validates all scripts inside a folder" $ do + r <- runTx con $ runMigration $ (MigrationValidation migrationDir) + r `shouldBe` Right MigrationSuccess + + it "validates an executed migration file" $ do + r <- runTx con $ runMigration $ (MigrationValidation migrationFile) + r `shouldBe` Right MigrationSuccess + + it "gets a list of executed migrations" $ do + r <- runTx con getMigrations + fmap (map schemaMigrationName) r `shouldBe` Right ["test.sql", "1.sql", "s.sql"] + + where + q = "create table t1 (c1 varchar);" + diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,28 @@ +-- | +-- Module : Main +-- Copyright : (c) 2014 Andreas Meingast +-- (c) 2016 Timo von Holtz +-- +-- License : BSD-style +-- Maintainer : tvh@tvholtz.de +-- Stability : experimental +-- Portability : GHC +-- +-- The test entry-point for postgresql-simple-migration. + +{-# LANGUAGE OverloadedStrings #-} + +module Main + ( main + ) where + +import Hasql.Connection +import Hasql.MigrationTest +import Test.Hspec (hspec) + +main :: IO () +main = do + con <- acquire "dbname=test" + case con of + Right con -> hspec (migrationSpec con) + Left err -> putStrLn $ show err