diff --git a/Changelog.markdown b/Changelog.markdown new file mode 100644 --- /dev/null +++ b/Changelog.markdown @@ -0,0 +1,8 @@ +# Changelog + +## 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/Readme.markdown b/Readme.markdown --- a/Readme.markdown +++ b/Readme.markdown @@ -34,6 +34,9 @@ * 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. @@ -49,6 +52,13 @@ ./dist/build/migrate/migrate migrate $CON $BASE_DIR ``` +To validate already executed scripts, execute the following: +```bash +CON="host=$host dbname=$db user=$user password=$pw" +./dist/build/migrate/migrate init $CON +./dist/build/migrate/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). @@ -85,9 +95,27 @@ 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 + void $ runMigration $ MigrationContext + (MigrationScript name script) True con ``` +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" + let name = "my script" + let script = "create table users (email varchar not null)"; + con <- connectPostgreSQL (BS8.pack url) + void $ runMigration $ MigrationContext + (MigrationValidation (MigrationDirectory dir)) verbose 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. @@ -106,4 +134,3 @@ ## To Do * Collect executed scripts and check if already executed scripts have been deleted. -* Validate command for the standalone program. diff --git a/postgresql-simple-migration.cabal b/postgresql-simple-migration.cabal --- a/postgresql-simple-migration.cabal +++ b/postgresql-simple-migration.cabal @@ -1,5 +1,5 @@ name: postgresql-simple-migration -version: 0.1.0.0 +version: 0.1.1.0 synopsis: PostgreSQL Schema Migrations homepage: https://github.com/ameingast/postgresql-simple-migration Bug-reports: https://github.com/ameingast/postgresql-simple-migration/issues @@ -15,9 +15,11 @@ extra-source-files: License Readme.markdown + Changelog.markdown src/*.hs src/Database/PostgreSQL/Simple/*.hs + src/Database/PostgreSQL/Simple/Internal/*.hs test/*.hs test/Database/PostgreSQL/Simple/*.hs @@ -31,6 +33,7 @@ Library exposed-modules: Database.PostgreSQL.Simple.Migration + Database.PostgreSQL.Simple.Internal.Util hs-source-dirs: src ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns default-extensions: OverloadedStrings @@ -40,7 +43,8 @@ bytestring >= 0.10 && < 0.11, cryptohash >= 0.11 && < 0.12, directory >= 1.2 && < 1.3, - postgresql-simple >= 0.4 && < 0.5 + postgresql-simple >= 0.4 && < 0.5, + time >= 1.4 && < 1.5 Executable migrate main-is: Main.hs @@ -53,7 +57,8 @@ bytestring >= 0.10 && < 0.11, cryptohash >= 0.11 && < 0.12, directory >= 1.2 && < 1.3, - postgresql-simple >= 0.4 && < 0.5 + postgresql-simple >= 0.4 && < 0.5, + time >= 1.4 && < 1.5 test-suite tests main-is: Main.hs diff --git a/src/Database/PostgreSQL/Simple/Internal/Util.hs b/src/Database/PostgreSQL/Simple/Internal/Util.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Internal/Util.hs @@ -0,0 +1,24 @@ +-- | +-- 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.Internal.Util + ( existsTable + ) where + +import Control.Monad (liftM) +import Database.PostgreSQL.Simple (Connection, Only (..), query) + +-- | Checks if the table named 'table' exists in the provided database. +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/src/Database/PostgreSQL/Simple/Migration.hs b/src/Database/PostgreSQL/Simple/Migration.hs --- a/src/Database/PostgreSQL/Simple/Migration.hs +++ b/src/Database/PostgreSQL/Simple/Migration.hs @@ -10,23 +10,43 @@ -- Migration library for postgresql-simple. module Database.PostgreSQL.Simple.Migration - ( runMigration + ( + -- * Migration actions + runMigration + + -- * Migration types , MigrationContext(..) , MigrationCommand(..) , MigrationResult(..) , ScriptName + , Checksum + + -- * Migration result actions + , getMigrations + + -- * Migration result types + , SchemaMigration(..) ) 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) +import Control.Applicative ((<$>), (<*>)) +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 Data.Time (LocalTime) +import Database.PostgreSQL.Simple (Connection, + Only (..), execute, + execute_, query, + query_) +import Database.PostgreSQL.Simple.FromRow (FromRow (..), field) +import Database.PostgreSQL.Simple.Internal.Util (existsTable) +import Database.PostgreSQL.Simple.ToField (ToField (..)) +import Database.PostgreSQL.Simple.ToRow (ToRow (..)) +import Database.PostgreSQL.Simple.Types (Query (..)) +import System.Directory (getDirectoryContents) -- | Executes migrations inside the provided 'MigrationContext'. runMigration :: MigrationContext -> IO (MigrationResult String) @@ -39,12 +59,14 @@ executeMigration con verbose name contents MigrationFile name path -> executeMigration con verbose name =<< BS.readFile path + MigrationValidation validationCmd -> + executeValidation con verbose validationCmd --- | Executes all SQL-file based migrations located in the provided 'dir'. +-- | Executes all SQL-file based migrations located in the provided 'dir' +-- in alphabetical order. executeDirectoryMigration :: Connection -> Bool -> FilePath -> IO (MigrationResult String) executeDirectoryMigration con verbose dir = - liftM (filter (\x -> not $ "." `isPrefixOf` x)) - (getDirectoryContents dir) >>= go . sort + scriptsInDirectory dir >>= go where go [] = return MigrationSuccess go (f:fs) = do @@ -55,6 +77,12 @@ MigrationSuccess -> go fs +-- | Lists all files in the given 'FilePath' 'dir' in alphabetical order. +scriptsInDirectory :: FilePath -> IO [String] +scriptsInDirectory dir = + liftM (sort . filter (\x -> not $ "." `isPrefixOf` x)) + (getDirectoryContents dir) + -- | Executes a generic SQL migration for the provided script 'name' with -- content 'contents'. executeMigration :: Connection -> Bool -> ScriptName -> BS.ByteString -> IO (MigrationResult String) @@ -88,6 +116,52 @@ , ");" ] +-- | 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. +executeValidation :: Connection -> Bool -> MigrationCommand -> IO (MigrationResult String) +executeValidation con verbose cmd = case cmd of + MigrationInitialization -> + existsTable con "schema_migrations" >>= \r -> return $ if r + then MigrationSuccess + else MigrationError "No such table: schema_migrations" + MigrationDirectory path -> + scriptsInDirectory path >>= goScripts path + MigrationScript name contents -> + validate name contents + MigrationFile name path -> + validate name =<< BS.readFile path + MigrationValidation _ -> + return MigrationSuccess + where + validate name contents = + checkScript con name (md5Hash contents) >>= \r -> case r of + ScriptOk -> do + when verbose $ putStrLn $ "Ok:\t" ++ name + return MigrationSuccess + ScriptNotExecuted -> do + when verbose $ putStrLn $ "Missing:\t" ++ name + return (MigrationError $ "Missing: " ++ name) + ScriptModified _ -> do + when verbose $ putStrLn $ "Checksum mismatch:\t" ++ name + return (MigrationError $ "Checksum mismatch: " ++ name) + + goScripts _ [] = return MigrationSuccess + goScripts path (x:xs) = do + r <- validate x =<< BS.readFile (path ++ "/" ++ x) + case r of + e@(MigrationError _) -> + return e + MigrationSuccess -> + goScripts path xs + -- | 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. @@ -133,6 +207,7 @@ -- 'FilePath'. | MigrationScript ScriptName BS.ByteString -- ^ Executes a migration based on the provided bytestring. + | MigrationValidation MigrationCommand deriving (Show, Eq, Read, Ord) -- | A sum-type denoting the result of a single migration. @@ -164,3 +239,33 @@ , migrationContextConnection :: Connection -- ^ The PostgreSQL connection to use for migrations. } + +-- | Produces a list of all executed 'SchemaMigration's. +getMigrations :: Connection -> IO [SchemaMigration] +getMigrations = flip query_ q + where q = mconcat + [ "select filename, checksum, executed_at " + , "from schema_migrations" + ] + +-- | 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/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -26,14 +26,21 @@ void $ case cmd of Initialize url -> do con <- connectPostgreSQL (BS8.pack url) - runMigration $ MigrationContext MigrationInitialization verbose con + runMigration $ MigrationContext + MigrationInitialization verbose con Migrate url dir -> do con <- connectPostgreSQL (BS8.pack url) - runMigration $ MigrationContext (MigrationDirectory dir) verbose con + runMigration $ MigrationContext + (MigrationDirectory dir) verbose con + Validate url dir -> do + con <- connectPostgreSQL (BS8.pack url) + runMigration $ MigrationContext + (MigrationValidation (MigrationDirectory dir)) verbose con parseCommand :: [String] -> Maybe Command parseCommand ("init":url:_) = Just (Initialize url) parseCommand ("migrate":url:dir:_) = Just (Migrate url dir) +parseCommand ("validate":url:dir:_) = Just (Validate url dir) parseCommand _ = Nothing printUsage :: IO () @@ -59,5 +66,6 @@ data Command = Initialize String - | Migrate String String + | Migrate String FilePath + | Validate String FilePath deriving (Show, Eq, Read, Ord) diff --git a/test/Database/PostgreSQL/Simple/MigrationTest.hs b/test/Database/PostgreSQL/Simple/MigrationTest.hs --- a/test/Database/PostgreSQL/Simple/MigrationTest.hs +++ b/test/Database/PostgreSQL/Simple/MigrationTest.hs @@ -2,30 +2,33 @@ 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) +import Database.PostgreSQL.Simple (Connection) +import Database.PostgreSQL.Simple.Internal.Util (existsTable) +import Database.PostgreSQL.Simple.Migration (MigrationCommand (..), MigrationContext (..), + MigrationResult (..), + SchemaMigration (..), + getMigrations, + runMigration) +import Test.Hspec (Spec, describe, it, + shouldBe) migrationSpec:: Connection -> Spec -migrationSpec con = describe "runMigration" $ do +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 "initializes a database" $ do - r <- runMigration $ - MigrationContext MigrationInitialization False con + r <- runMigration $ MigrationContext MigrationInitialization False con r `shouldBe` MigrationSuccess - it "creates the schema_migration table" $ do + it "creates the schema_migrations 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 <- runMigration $ MigrationContext migrationScript False con r `shouldBe` MigrationSuccess it "creates the table from the executed script" $ do @@ -34,17 +37,15 @@ it "skips execution of the same migration script" $ do r <- runMigration $ - MigrationContext (MigrationScript "test.sql" q) False con + MigrationContext migrationScript 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 <- runMigration $ MigrationContext migrationScriptAltered 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 <- runMigration $ MigrationContext migrationDir False con r `shouldBe` MigrationSuccess it "creates the table from the executed scripts" $ do @@ -52,18 +53,37 @@ r `shouldBe` True it "executes a file based migration script" $ do - r <- runMigration $ - MigrationContext (MigrationFile "s.sql" "share/test/script.sql") False con + 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);" -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 = ?"