diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2017 Bardur Arantsson + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. 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/peregrin.cabal b/peregrin.cabal new file mode 100644 --- /dev/null +++ b/peregrin.cabal @@ -0,0 +1,44 @@ +Name: peregrin +Version: 0.1.0 +Synopsis: Database migration support for use in other libraries. +Description: Database migration support for use in other libraries. + Currently only supports PostgreSQL. +License: MIT +License-file: LICENSE +Category: Database +Cabal-version: >=1.10 +Build-type: Simple +Author: Bardur Arantsson +Maintainer: Bardur Arantsson + +Source-Repository head + Type: git + Location: https://github.com/BardurArantsson/peregrin + +Library + build-depends: base >= 4.9 && < 5 + , postgresql-simple >= 0.5.2.1 && < 0.6 + , text >= 1.1.0 && < 2 + default-language: Haskell2010 + ghc-options: -Wall + hs-source-dirs: src + exposed-modules: Database.Peregrin.Metadata + Database.Peregrin + +Test-Suite tests + type: exitcode-stdio-1.0 + hs-source-dirs: src-test + main-is: Main.hs + build-depends: base == 4.* + , pg-harness-client >= 0.4.0 && < 0.5.0 + , postgresql-simple >= 0.5.2.1 && < 0.6 + , resource-pool >= 0.2.1 && < 0.3 + , text >= 1.0 && < 2 + , transformers >= 0.5.2 && < 0.6 + -- Self-dependency: + , peregrin + -- Test framework: + , hspec >= 2.2.0 && < 3.0 + default-language: Haskell2010 + ghc-options: -Wall + other-modules: Database.PeregrinSpec diff --git a/src-test/Database/PeregrinSpec.hs b/src-test/Database/PeregrinSpec.hs new file mode 100644 --- /dev/null +++ b/src-test/Database/PeregrinSpec.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Database.PeregrinSpec + ( mkMigrateSpec + ) where + +import Control.Exception (Exception, bracket) +import Control.Monad (forM_) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask) +import Database.Peregrin +import Database.Peregrin.Metadata +import Data.Pool (Pool, withResource, destroyAllResources) +import Data.Text (Text) +import Database.PostgreSQL.Simple (Connection, Query, Only(..), FromRow) +import qualified Database.PostgreSQL.Simple as PS +import Test.Hspec (Spec, Selector, describe) +import qualified Test.Hspec as Hspec + +-- | Create specs. +mkMigrateSpec :: IO (Pool Connection) -> Spec +mkMigrateSpec mkConnectionPool = + forM_ [DefaultSchema, NamedSchema "foobar"] $ \schema -> do + -- Show which case we're in + let extra = case schema of + DefaultSchema -> " (default schema)" + NamedSchema _ -> " (named schema)" + -- Specs: + describe ("migrate" ++ extra) $ do + it "can apply a single migration" $ do + -- Exercise: + migrate' schema [ (cid0, createXSql) ] + -- Verify: + assertCanSelectFromX + + it "ignores migrations that have already been applied (single call)" $ do + -- Exercise: + migrate' schema [ (cid0, createXSql) + , (cid0, createXSql) -- Would fail if applied again + ] + -- Verify: + assertCanSelectFromX + + it "ignores migrations that have already been applied (multiple calls)" $ do + -- Exercise: + migrate' schema [ (cid0, createXSql) ] + migrate' schema [ (cid0, createXSql) ] -- Would fail if applied again + -- Verify: + assertCanSelectFromX + + it "throws an error if SQL is changed for a given change set ID" $ do + -- Exercise: + migrate' schema [ (cid0, createXSql) ] + migrate' schema [ (cid0, createXSqlBad) ] + -- Verify: Should throw here + `shouldThrow` (== MigrationModifiedError cid0) + + it "can apply multiple distinct migrations in a single call" $ do + -- Exercise + migrate' schema [ (cid0, createXSql) + , (cid1, createYSql) + ] + -- Verify: Make sure both migrations have been applied + assertCanSelectFromXY + + where + it msg action = Hspec.it msg $ + bracket mkConnectionPool destroyAllResources $ runReaderT action + + createXSql = "CREATE TABLE X (A INT)" + createYSql = "CREATE TABLE Y (B INT)" + createXSqlBad = "CREATE TABLE X (Y CHAR(1))" + + assertCanSelectFromX = + assertCanQuery_ "SELECT * FROM X" + + assertCanSelectFromXY = + assertCanQuery_ "SELECT * FROM X, Y where X.A = Y.B" + + cid0 = "a328156d-9875-4471-8192-0c86959badb3" + cid1 = "00c6159c-c7f6-4cec-b63f-f70c1c4c7bb1" + +assertCanQuery_ :: Query -> ReaderT (Pool Connection) IO () +assertCanQuery_ q = do + _ :: [Only Int] <- query_ q + return () + +query_ :: FromRow a => Query -> ReaderT (Pool Connection) IO [a] +query_ sql = do + connectionPool <- ask + withResource connectionPool $ \connection -> + lift $ PS.query_ connection sql + +shouldThrow :: Exception e => ReaderT (Pool Connection) IO a -> Selector e -> ReaderT (Pool Connection) IO () +shouldThrow action selector = do + connectionPool <- ask + lift (Hspec.shouldThrow (runReaderT action connectionPool) selector) + +migrate' :: Schema -> [(Text, Text)] -> ReaderT (Pool Connection) IO () +migrate' schema migrations = do + connectionPool <- ask + lift $ withResource connectionPool $ \connection -> + migrate connection schema migrations diff --git a/src-test/Main.hs b/src-test/Main.hs new file mode 100644 --- /dev/null +++ b/src-test/Main.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main ( main ) where + +import Control.Applicative ((<$>)) +import Database.PeregrinSpec ( mkMigrateSpec ) +import Data.Pool (createPool) +import qualified Database.PostgreSQL.Harness.Client as H +import Database.PostgreSQL.Simple (connectPostgreSQL, close) +import Test.Hspec + +main :: IO () +main = do + -- HSpec has no easy way to get "other" command line parameters, so + -- we'll just settle for a hardcoded value here. + let url = "http://localhost:8900" + -- Connection pool creation function. We use a fresh temporary + -- database for every connection pool. + let mkConnectionPool = do + connectionString <- H.toConnectionString <$> H.createTemporaryDatabase url + createPool (connectPostgreSQL connectionString) close 1 1 5 + -- Run + hspec $ mkMigrateSpec mkConnectionPool diff --git a/src/Database/Peregrin.hs b/src/Database/Peregrin.hs new file mode 100644 --- /dev/null +++ b/src/Database/Peregrin.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Database.Peregrin + ( migrate + , MigrationError(..) + ) where + +import Control.Applicative ((<$>)) +import Control.Exception (Exception, throwIO) +import Control.Monad (forM_, when, void) +import Database.Peregrin.Metadata +import Data.Text (Text) +import qualified Data.Text as T +import Data.Int (Int32, Int64) +import Data.Maybe (listToMaybe, fromMaybe) +import Data.String (fromString) +import Database.PostgreSQL.Simple (Connection, Only(..), Query) +import qualified Database.PostgreSQL.Simple as P +import Database.PostgreSQL.Simple.ToField (ToField(..)) +import Database.PostgreSQL.Simple.FromRow (FromRow(..), field) +import Database.PostgreSQL.Simple.Transaction (withTransactionLevel, IsolationLevel(..)) + +-- | Migration information stored in 'migration' table. +data Migration = Migration Text Text + +instance FromRow Migration where + fromRow = Migration <$> field <*> field + +-- | Exception happened running migrations. +data MigrationError = + -- | The migration with the given ID has been modified in the + -- program code since it was applied. Since this can have very + -- unpredictable effects it is considered an error. + MigrationModifiedError Text + deriving (Show, Eq) + +instance Exception MigrationError + +-- | Context for migrations. +data MigrationContext = MigrationContext { mcMetaMigrationTable :: Table + , mcMigrationTable :: Table + } + +-- | Apply a list of migrations to a database. For example, +-- +-- > migrate conn schema [("a", "CREATE TABLE ...")] +-- > [("b", "INSERT INTO TABLE ...")] +-- +-- will apply the given SQL statements __in order__ and track them by +-- the identifiers "a" and "b". It is recommended to use __fixed__, +-- randomly generated UUIDs to identify migrations, though you are +-- free to use whatever identifiers you like as long as they are +-- unique within the given schema. For example, on a Linux system you +-- can run the command `uuidgen -r` on the command line and paste that +-- into your migration list. +-- +-- The given 'Schema' parameter indicates the schema used for the +-- /metadata/ stored to track which migrations have been applied. It +-- does not affect the migrations themselves in any way. Therefore, +-- __ALL__ migrations should __ALWAYS__ specify their schema +-- explicitly in the SQL. +-- +-- Any migrations that have already been applied will be skipped. If +-- the SQL text for any given migration /changes/, a +-- 'MigrationModifiedError' exception will be thrown. +-- +-- Migrations are tracked using two tables, namely +-- "@\__peregrin_migration_meta\__@" and "@\__peregrin_migration\__@", +-- which will automatically be created in the given 'Schema'. +-- +migrate :: Connection -> Schema -> [(Text, Text)] -> IO () +migrate connection schema = + migrate' tables connection schema + where + tables = MigrationContext { mcMetaMigrationTable = Table schema "__peregrin_migration_meta__" + , mcMigrationTable = Table schema "__peregrin_migration__" + } + +migrate' :: MigrationContext -> Connection -> Schema -> [(Text, Text)] -> IO () +migrate' tables c schema migrations = do + -- Must always create the "migration_meta" table (and its + -- schema) if necessary. Having just created this table without + -- any rows represents "version 0" of the metadata data + -- structures. These operations are idempotent and so we don't + -- need any lock. + void $ transact $ execute sqlCreateSchema [ schema ] + void $ transact $ execute sqlCreateMetaTbl [ metaTable ] + -- Apply meta-migrations. + withLock $ + -- Apply meta-migrations; these are hardcoded for obvious reasons. + -- EXCEPT for the very first migration, NO changes may be made to + -- the "migration_meta" table in any migration here. This is to + -- ensure 'perpetual' compatibility. + metaMigrate 1 [ (sqlInsertMetaVersion0, [metaTable]) + , (sqlCreateMigrationTbl, [migrationTable]) + ] + -- Apply all the migrations; we do it one-by-one since our lock is + -- itself automatically released by PostgreSQL at the end of each of + -- each transaction. + forM_ migrations $ \(mid, sql) -> + withLock $ do + -- Check if change set has already been applied + existingMigration :: (Maybe Migration) <- + listToMaybe <$> query sqlFindMigration + [ toField migrationTable + , toField mid ] + case existingMigration of + Just (Migration _ sql') | sql == sql' -> + return () + Just _ -> + throwIO $ MigrationModifiedError mid + Nothing -> do + void $ execute sqlInsertMigration [ toField migrationTable + , toField mid + , toField sql + ] + void $ execute_ $ fromString $ T.unpack sql + + where + + -- Tables + migrationTable = mcMigrationTable tables + metaTable = mcMetaMigrationTable tables + + -- Apply a meta-migration. + metaMigrate :: ToField a => Int32 -> [(Query, [a])] -> IO () + metaMigrate metaVersion sqls = do + -- Get the meta-version; defaults to 0 if we've only just + -- created the metadata table. + Only currentMetaVersion <- fromMaybe (Only 0) <$> fmap listToMaybe (query sqlGetMetaVersion [metaTable]) + -- If the migration is applicable, then we apply it. + when (currentMetaVersion + 1 == metaVersion) $ do + forM_ sqls $ \(q, ps) -> execute q ps + rowCount <- execute sqlUpdateMetaVersion [ toField metaTable + , toField metaVersion + , toField currentMetaVersion + ] + when (rowCount /= 1) $ error $ "Unexpected row count " ++ show rowCount ++ " from update on \"migration_meta\" table!" + + -- Shorthand: + transact = withTransactionLevel ReadCommitted c + + execute :: ToField a => Query -> [a] -> IO Int64 + execute = P.execute c + + execute_ :: Query -> IO Int64 + execute_ = P.execute_ c + + query :: (ToField a, FromRow r) => Query -> [a] -> IO [r] + query = P.query c + + -- Perform a transaction with the exclusive lock held. The lock is + -- automatically released when the transaction ends. + withLock txn = + transact $ do + void $ execute sqlLockMetaTbl [metaTable] + txn + + -- Support SQL: + sqlCreateSchema = + "CREATE SCHEMA IF NOT EXISTS ?" + + sqlCreateMetaTbl = + "CREATE TABLE IF NOT EXISTS ? (\ + \ \"meta_version\" INTEGER PRIMARY KEY\ + \)" + + sqlGetMetaVersion = + "SELECT \"meta_version\" FROM ?" + + sqlUpdateMetaVersion = + "UPDATE ? \ + \ SET \"meta_version\" = ? \ + \ WHERE \"meta_version\" = ?" + + sqlLockMetaTbl = + "LOCK TABLE ? IN ACCESS EXCLUSIVE MODE" + + sqlInsertMetaVersion0 = + "INSERT INTO ? (\"meta_version\") VALUES (0)" + + sqlCreateMigrationTbl = + "CREATE TABLE ? ( \ + \ \"id\" TEXT PRIMARY KEY,\ + \ \"sql\" TEXT NOT NULL\ + \)" + + sqlFindMigration = + "SELECT \"id\", \"sql\"\ + \ FROM ? \ + \ WHERE \"id\" = ?" + + sqlInsertMigration = + "INSERT INTO ? \ + \ (\"id\", \"sql\") \ + \ VALUES (?, ?)" diff --git a/src/Database/Peregrin/Metadata.hs b/src/Database/Peregrin/Metadata.hs new file mode 100644 --- /dev/null +++ b/src/Database/Peregrin/Metadata.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE OverloadedStrings #-} +module Database.Peregrin.Metadata + ( Schema(..) + , Table(..) + , ToSQL(..) + , Typ(..) + ) where + +import qualified Data.Text as T +import Data.Text (Text) +import Database.PostgreSQL.Simple.ToField (ToField(..)) +import Database.PostgreSQL.Simple.Types (Identifier(..), QualifiedIdentifier(..)) + +-- | A schema designation. +data Schema = DefaultSchema + | NamedSchema Text + +instance ToField Schema where + toField schema = toField $ Identifier $ schemaToText schema + +-- | Convert schema to 'Text'. +schemaToText :: Schema -> Text +schemaToText DefaultSchema = "public" +schemaToText (NamedSchema schemaId) = schemaId + +-- | Create a qualified identifier. +mkQualifiedIdentifier :: Schema -> Text -> QualifiedIdentifier +mkQualifiedIdentifier schema = QualifiedIdentifier (Just $ schemaToText schema) + +-- | Table name, including which schema it is in. +data Table = Table Schema Text + +instance ToField Table where + toField (Table schema name) = toField $ mkQualifiedIdentifier schema name + +-- | Type name, including which schema it is in. +data Typ = Typ Schema Text + +instance ToField Typ where + toField (Typ schema name) = toField $ mkQualifiedIdentifier schema name + +-- | Quote a PostgreSQL object identifier. Useful in circumstances +-- where you need to quote a dynamically generated identifier. +quoteToSQL :: Text -> Text +quoteToSQL i = T.concat [ singleQt + , T.replace singleQt doubleQt i + , singleQt + ] + where + singleQt = "\"" + doubleQt = "\"\"" + +-- | Convert metadata object identifier to its quoted SQL +-- representation. +class ToSQL a where + toSQL :: a -> Text + +-- +-- Instances +-- + +instance ToSQL Schema where + toSQL DefaultSchema = quoteToSQL "public" + toSQL (NamedSchema schemaId) = quoteToSQL schemaId + +instance ToSQL Table where + toSQL (Table schema tableId) = + T.concat [toSQL schema, ".", quoteToSQL tableId] + +instance ToSQL Typ where + toSQL (Typ schema tableId) = + T.concat [toSQL schema, ".", quoteToSQL tableId]