diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2020, Tobias Dammers + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * 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. + + * Neither the name of Tobias Dammers nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 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 COPYRIGHT +OWNER 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/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/migrant-core.cabal b/migrant-core.cabal new file mode 100644 --- /dev/null +++ b/migrant-core.cabal @@ -0,0 +1,45 @@ +cabal-version: 2.4 +-- Initial package description 'migrant.cabal' generated by 'cabal init'. +-- For further documentation, see http://haskell.org/cabal/users-guide/ + +name: migrant-core +version: 0.1.0.0 +synopsis: Semi-automatic database schema migrations +-- description: +homepage: https://github.com/tdammers/migrant +-- bug-reports: +license: BSD-3-Clause +license-file: LICENSE +author: Tobias Dammers +maintainer: tdammers@gmail.com +-- copyright: +category: Database +extra-source-files: + +library + exposed-modules: Database.Migrant + , Database.Migrant.Run + , Database.Migrant.Driver.Class + , Database.Migrant.MigrationName + -- other-extensions: + build-depends: base ^>=4.12.0.0 + , text >=1.2.4.0 && <1.3 + hs-source-dirs: src + default-language: Haskell2010 + +test-suite migrant-core-test + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + other-modules: Database.Migrant.Run_Orphans + , Database.Migrant.MigrationName_Orphans + , Database.Migrant.Run_Tests + build-depends: base ^>=4.12.0.0 + , migrant-core + , HUnit >=1.6.1.0 && <1.7 + , QuickCheck >=2.14.2 && <2.15 + , tasty >=1.4 && <1.5 + , tasty-hunit >=0.10.0.2 && <0.11 + , tasty-quickcheck >=0.10.1.1 && <0.11 + , text >=1.2.4.0 && <1.3 diff --git a/src/Database/Migrant.hs b/src/Database/Migrant.hs new file mode 100644 --- /dev/null +++ b/src/Database/Migrant.hs @@ -0,0 +1,12 @@ +module Database.Migrant +( Driver (..) +, MigrationName +, MigrationDirection +, migrate +, plan +) +where + +import Database.Migrant.Driver.Class +import Database.Migrant.MigrationName +import Database.Migrant.Run diff --git a/src/Database/Migrant/Driver/Class.hs b/src/Database/Migrant/Driver/Class.hs new file mode 100644 --- /dev/null +++ b/src/Database/Migrant/Driver/Class.hs @@ -0,0 +1,50 @@ +{-#LANGUAGE TypeFamilies #-} +module Database.Migrant.Driver.Class +where + +import Database.Migrant.MigrationName (MigrationName) +import Data.Text (Text) +import Text.Printf (printf) +import Control.Monad + +-- | A migrations driver abstracts over the database to run over and the +-- associated migration mechanism. +class Driver d where + -- | Migrations should be done transactionally, so we need to provide a + -- way of wrapping things in a transaction. Implementations should make + -- sure that whatever runs inside a transaction is actually transactional + -- (i.e., atomic), including host exceptions. + withTransaction :: (d -> IO a) -> d -> IO a + + -- | Initialize the migrations system on the backend. This should generally + -- involve creating a table of ordered migration names, e.g.: + -- @@@ + -- CREATE TABLE IF NOT EXISTS _migrations (id SERIAL PRIMARY KEY, name TEXT); + -- @@@ + -- + -- **Note** that 'initMigrations' should be idempotent, that is, executing it + -- when the migrations system has already been initialized should be a no-op. + initMigrations :: d -> IO () + + -- | Mark a migration as \"executed\". Typically, this will @INSERT@ a row + -- into the migrations table. + markUp :: MigrationName -> d -> IO () + + -- | Mark a migration as \"not executed\" / \"rolled back\". Typically, this + -- will @DELETE@ a row from the migrations table. + markDown :: MigrationName -> d -> IO () + + -- | Get the list of migrations applied to the backend, in the order they + -- were applied. + getMigrations :: d -> IO [MigrationName] + +data DummyDriver = DummyDriver + +instance Driver DummyDriver where + withTransaction = id + initMigrations = const mzero + markUp migration _ = + printf "UP: %s" migration + markDown migration _ = + printf "DOWN: %s" migration + getMigrations _ = return [] diff --git a/src/Database/Migrant/MigrationName.hs b/src/Database/Migrant/MigrationName.hs new file mode 100644 --- /dev/null +++ b/src/Database/Migrant/MigrationName.hs @@ -0,0 +1,15 @@ +{-#LANGUAGE GeneralizedNewtypeDeriving #-} +{-#LANGUAGE DerivingVia #-} +module Database.Migrant.MigrationName +where + +import Data.Text +import Text.Printf +import Data.String (IsString) + +newtype MigrationName = + MigrationName { unpackMigrationName :: Text } + deriving Eq via Text + deriving Show via Text + deriving PrintfArg via Text + deriving IsString via Text diff --git a/src/Database/Migrant/Run.hs b/src/Database/Migrant/Run.hs new file mode 100644 --- /dev/null +++ b/src/Database/Migrant/Run.hs @@ -0,0 +1,108 @@ +module Database.Migrant.Run +( migrate +, unsafeMigrate +, executePlan +, plan +, makePlan +, MigrationDirection (..) +) +where + +import Database.Migrant.Driver.Class +import Database.Migrant.MigrationName + +import Control.Monad (forM_) + +data MigrationDirection + = MigrateUp + | MigrateDown + deriving (Show, Eq, Ord, Enum, Bounded) + +-- | Create a migration plan based on the current situation on the database, +-- and the specified target. +plan :: Driver d + => [MigrationName] + -> d + -> IO [(MigrationDirection, MigrationName)] +plan target driver = do + current <- getMigrations driver + return $ makePlan target current + +-- | Make a plan from a previously loaded current situation and the specified +-- target. +makePlan :: [MigrationName] + -- ^ target + -> [MigrationName] + -- ^ current + -> [(MigrationDirection, MigrationName)] +makePlan [] [] + -- Situation 0: nothing left to do + = [] +makePlan [] xs + -- Situation 1: no more "up" targets left, but more migrations exist, so + -- we need to roll those back. + = [(MigrateDown, n) | n <- xs] +makePlan xs [] + -- Situation 2: only "up" targets left, run them. + = [(MigrateUp, n) | n <- xs] +makePlan (t:ts) (c:cs) + -- Situation 3: "up" targets exist, and we also have existing migrations + -- left. The same migration exists on both ends, so we can just skip + -- forward. + | t == c + = makePlan ts cs + -- Situation 4: both "up" targets and existing migrations are present but the + -- do not match, so we need to roll back existing migrations until a + -- consistent situation is restored. + | otherwise + = (MigrateDown, c):makePlan (t:ts) cs + +-- | Apply a migration plan to a database. +-- This should generally be done within the same transaction as loading the +-- current situation from the database and creating a migration plan. Running +-- this action outside of a transaction may leave the database and migration +-- tracking in an inconsistent state. +executePlan :: Driver d + => [(MigrationDirection, MigrationName)] + -> (MigrationName -> d -> IO ()) + -> (MigrationName -> d -> IO ()) + -> d + -> IO () +executePlan migrationPlan up down driver = do + forM_ migrationPlan $ \(direction, name) -> do + let (run, mark) = case direction of + MigrateUp -> (up, markUp) + MigrateDown -> (down, markDown) + run name driver + mark name driver + +-- | Safely (transactionally) infer and execute a migration. +migrate :: Driver d + => [MigrationName] + -- ^ Target situation + -> (MigrationName -> d -> IO ()) + -- ^ Factory for \'up\' migration actions + -> (MigrationName -> d -> IO ()) + -- ^ Factory for \'down\' migration actions + -> d + -> IO () +migrate target up down driver = + withTransaction (unsafeMigrate target up down) driver + +-- | Infer and execute a migration in a non-transactional fashion. This means +-- that migration failures may leave the database and migration tracking in +-- an inconsistent state, so you should never call this outside of a +-- transaction. +unsafeMigrate :: Driver d + => [MigrationName] + -- ^ Target situation + -> (MigrationName -> d -> IO ()) + -- ^ Factory for \'up\' migration actions + -> (MigrationName -> d -> IO ()) + -- ^ Factory for \'down\' migration actions + -> d + -> IO () +unsafeMigrate target up down driver = do + initMigrations driver + migrationPlan <- plan target driver + executePlan migrationPlan up down driver diff --git a/test/Database/Migrant/MigrationName_Orphans.hs b/test/Database/Migrant/MigrationName_Orphans.hs new file mode 100644 --- /dev/null +++ b/test/Database/Migrant/MigrationName_Orphans.hs @@ -0,0 +1,9 @@ +module Database.Migrant.MigrationName_Orphans +where + +import Test.Tasty.QuickCheck +import Database.Migrant.MigrationName +import qualified Data.Text as Text + +instance Arbitrary MigrationName where + arbitrary = MigrationName . Text.pack <$> arbitrary diff --git a/test/Database/Migrant/Run_Orphans.hs b/test/Database/Migrant/Run_Orphans.hs new file mode 100644 --- /dev/null +++ b/test/Database/Migrant/Run_Orphans.hs @@ -0,0 +1,12 @@ +{-#LANGUAGE LambdaCase #-} +module Database.Migrant.Run_Orphans +where + +import Test.Tasty.QuickCheck +import Database.Migrant.Run +import qualified Data.Text as Text + +instance Arbitrary MigrationDirection where + arbitrary = arbitrary >>= \case + True -> return MigrateUp + False -> return MigrateDown diff --git a/test/Database/Migrant/Run_Tests.hs b/test/Database/Migrant/Run_Tests.hs new file mode 100644 --- /dev/null +++ b/test/Database/Migrant/Run_Tests.hs @@ -0,0 +1,197 @@ +{-#LANGUAGE ScopedTypeVariables #-} +{-#LANGUAGE OverloadedStrings #-} + +module Database.Migrant.Run_Tests +where + +import Test.Tasty +import Test.Tasty.QuickCheck +import Test.Tasty.HUnit + +import Data.Text (Text) +import qualified Data.Text as Text +import Data.List (isSuffixOf, isPrefixOf) +import Data.IORef +import Control.Exception +import System.IO.Unsafe (unsafePerformIO) + +import Database.Migrant.Run +import Database.Migrant.Driver.Class +import Database.Migrant.MigrationName +import Database.Migrant.MigrationName_Orphans +import Database.Migrant.Run_Orphans + +tests = testGroup "Database.Migrant.Run" + [ testGroup "makePlan" + makePlanTests + , testGroup "executePlan" + executePlanTests + , testGroup "migrateTests" + migrateTests + ] + +makePlanTests :: [TestTree] +makePlanTests = + [ testProperty "same inputs, empty diff" propSameInputEmptyDiff + , testProperty "appended becomes diff" propAppendIsDiff + , testProperty "removed becomes diff" propRemoveIsDiff + , testProperty "diff length never longer than inputs combined" propDiffNotLargerThanInputs + , testProperty "removeBeforeAdd" propRemoveBeforeAdd + ] + +propSameInputEmptyDiff migs = + makePlan migs migs == [] + +propAppendIsDiff base ext = + makePlan (base ++ ext) base == [(MigrateUp, m) | m <- ext] + +propRemoveIsDiff base ext = + makePlan base (base ++ ext) == [(MigrateDown, m) | m <- ext] + +propDiffNotLargerThanInputs target current = + length (makePlan target current) <= length target + length current + +propRemoveBeforeAdd ext1 ext2 = + all not ((==) <$> ext1 <*> ext2) ==> + makePlan ext1 ext2 == + [(MigrateDown, e) | e <- ext2] ++ + [(MigrateUp, e) | e <- ext1] + +executePlanTests :: [TestTree] +executePlanTests = + [ testProperty "updates only" propExecuteUpdatesOnly + , testProperty "rollbacks only" propExecuteRollbacksOnly + , testProperty "mixed updates/rollbacks" propExecuteMixed + ] + +propExecuteUpdatesOnly target = + let expected = [("MARK MigrateUp " <> unpackMigrationName n) | n <- target] + plan = [(MigrateUp, n) | n <- target] + getMigration _ _ = return () + logged = runChat (executePlan plan getMigration getMigration) [] + in logged == expected + +propExecuteRollbacksOnly target = + let expected = [("MARK MigrateDown " <> unpackMigrationName n) | n <- target] + plan = [(MigrateDown, n) | n <- target] + getMigration _ _ = return () + logged = runChat (executePlan plan getMigration getMigration) [] + in logged == expected + +propExecuteMixed plan = + let expected = [("MARK " <> Text.pack (show d) <> " " <> unpackMigrationName n) | (d, n) <- plan] + getMigration _ _ = return () + logged = runChat (executePlan plan getMigration getMigration) [] + in logged == expected + +migrateTests :: [TestTree] +migrateTests = + [ testCase "transactionally do nothing" testMigrateNothing + , testCase "transactionally do something" testMigrateSomething + , testCase "roll back on host failure" testMigrateError + ] + +testMigrateNothing :: Assertion +testMigrateNothing = do + let target = [] + up name = logChatQuery ("MigrateUp " <> unpackMigrationName name) + down name = logChatQuery ("MigrateDown " <> unpackMigrationName name) + actual <- runChatIO (migrate target up down) [[]] + let expected = + [ "BEGIN TRANSACTION" + , "INIT" + , "COMMIT TRANSACTION" + ] + assertEqual "migration log" expected actual + +testMigrateSomething :: Assertion +testMigrateSomething = do + let target = ["foo", "bar"] + situation = ["bar", "quux"] + up name = logChatQuery ("MigrateUp " <> unpackMigrationName name) + down name = logChatQuery ("MigrateDown " <> unpackMigrationName name) + actual <- runChatIO (migrate target up down) (repeat situation) + let expected = + [ "BEGIN TRANSACTION" + , "INIT" + , "MigrateDown bar" + , "MARK MigrateDown bar" + , "MigrateDown quux" + , "MARK MigrateDown quux" + , "MigrateUp foo" + , "MARK MigrateUp foo" + , "MigrateUp bar" + , "MARK MigrateUp bar" + , "COMMIT TRANSACTION" + ] + assertEqual "migration log" expected actual + +testMigrateError :: Assertion +testMigrateError = do + let target = ["foo"] + situation = ["bar"] + up name driver = throwIO DummyError + down name = logChatQuery ("MigrateDown " <> unpackMigrationName name) + actual <- runChatIO (migrate target up down) (repeat situation) + let expected = + [ "BEGIN TRANSACTION" + , "INIT" + , "MigrateDown bar" + , "MARK MigrateDown bar" + , "ROLLBACK TRANSACTION" + ] + assertEqual "migration log" expected actual + +-- | A mockup driver we can use to test the migration planner/executor +data ChatDriver = + ChatDriver + { queries :: IORef [Text] + , responses :: IORef [[MigrationName]] + } + +logChatQuery :: Text -> ChatDriver -> IO () +logChatQuery msg ChatDriver { queries = queries } = + modifyIORef queries (++ [msg]) + +runChatIO :: (ChatDriver -> IO ()) -> [[MigrationName]] -> IO [Text] +runChatIO action responses = do + queriesRef <- newIORef [] + responsesRef <- newIORef responses + action (ChatDriver queriesRef responsesRef) + readIORef queriesRef + +runChat :: (ChatDriver -> IO ()) -> [[MigrationName]] -> [Text] +runChat action responses = unsafePerformIO (runChatIO action responses) + +instance Driver ChatDriver where + withTransaction action driver = do + logChatQuery "BEGIN TRANSACTION" driver + catch + (do + result <- action driver + logChatQuery "COMMIT TRANSACTION" driver + return result + ) + (\(e :: SomeException) -> do + logChatQuery "ROLLBACK TRANSACTION" driver + return undefined + ) + + initMigrations driver = do + logChatQuery "INIT" driver + + markUp name driver = do + logChatQuery ("MARK MigrateUp " <> unpackMigrationName name) driver + + markDown name driver = do + logChatQuery ("MARK MigrateDown " <> unpackMigrationName name) driver + + getMigrations driver = do + (r:rs) <- readIORef (responses driver) + writeIORef (responses driver) rs + return r + +data DummyError = DummyError + deriving (Show) + +instance Exception DummyError where diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,16 @@ +module Main (main) where + +import Test.Tasty +import Test.Tasty.QuickCheck +import Test.Tasty.HUnit + +import Data.Text (Text) +import qualified Data.Text as Text + +import qualified Database.Migrant.Run_Tests + +main :: IO () +main = defaultMain $ + testGroup "Migrant" + [ Database.Migrant.Run_Tests.tests + ]