├── test ├── config_loading │ ├── missing.cfg │ ├── invalid.cfg │ ├── cfg1.cfg │ ├── moo.cfg │ └── cfg_ts.cfg ├── migration_parsing │ ├── invalid_missing_required_fields.txt │ ├── valid_no_desc.txt │ ├── valid_no_revert.txt │ ├── valid_no_timestamp.txt │ ├── invalid_syntax.txt │ ├── valid_no_depends.txt │ ├── invalid_timestamp.txt │ ├── valid_full.txt │ ├── invalid_field_name.txt │ ├── valid_with_multiline_deps.txt │ ├── valid_with_colon.txt │ ├── valid_with_comments2.txt │ └── valid_with_comments.txt ├── example_store │ ├── root │ ├── update2 │ └── update1 ├── CommonTH.hs ├── Common.hs ├── InMemoryStore.hs ├── FilesystemTest.hs ├── Main.hs ├── CycleDetectionTest.hs ├── MigrationsTest.hs ├── FilesystemSerializeTest.hs ├── ConfigurationTest.hs ├── LinearMigrationsTest.hs ├── DependencyTest.hs ├── StoreTest.hs └── FilesystemParseTest.hs ├── .gitignore ├── Setup.lhs ├── .travis.yml ├── programs └── Moo.hs ├── src ├── Database │ └── Schema │ │ ├── Migrations │ │ ├── Migration.hs │ │ ├── CycleDetection.hs │ │ ├── Filesystem │ │ │ └── Serialize.hs │ │ ├── Backend │ │ │ └── HDBC.hs │ │ ├── Backend.hs │ │ ├── Dependencies.hs │ │ ├── Filesystem.hs │ │ ├── Store.hs │ │ └── Test │ │ │ └── BackendTest.hs │ │ └── Migrations.hs ├── Moo │ ├── Main.hs │ ├── CommandInterface.hs │ ├── CommandHandlers.hs │ ├── Core.hs │ └── CommandUtils.hs └── StoreManager.hs ├── LICENSE ├── README.md ├── CHANGELOG.md ├── dbmigrations.cabal └── MOO.TXT /test/config_loading/missing.cfg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/config_loading/invalid.cfg: -------------------------------------------------------------------------------- 1 | MALFORMED_ = 2 | CONFIG = ASD 3 | FILE 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .*.swp 2 | .cabal-sandbox 3 | cabal.sandbox.config 4 | dist 5 | dist-newstyle 6 | -------------------------------------------------------------------------------- /Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | > import Distribution.Simple 3 | > main = defaultMain 4 | -------------------------------------------------------------------------------- /test/config_loading/cfg1.cfg: -------------------------------------------------------------------------------- 1 | DBM_DATABASE = "connection" 2 | DBM_MIGRATION_STORE = "store" 3 | DBM_LINEAR_MIGRATIONS = on 4 | -------------------------------------------------------------------------------- /test/config_loading/moo.cfg: -------------------------------------------------------------------------------- 1 | DBM_DATABASE = "mooconn" 2 | DBM_MIGRATION_STORE = "moostore" 3 | DBM_LINEAR_MIGRATIONS = on 4 | -------------------------------------------------------------------------------- /test/config_loading/cfg_ts.cfg: -------------------------------------------------------------------------------- 1 | DBM_DATABASE = "connection" 2 | DBM_MIGRATION_STORE = "store" 3 | DBM_LINEAR_MIGRATIONS = on 4 | DBM_TIMESTAMP_FILENAMES = true 5 | -------------------------------------------------------------------------------- /test/migration_parsing/invalid_missing_required_fields.txt: -------------------------------------------------------------------------------- 1 | Description: A valid full migration. 2 | Apply: 3 | 4 | CREATE TABLE test ( 5 | a int 6 | ); 7 | 8 | Revert: DROP TABLE test; 9 | -------------------------------------------------------------------------------- /test/migration_parsing/valid_no_desc.txt: -------------------------------------------------------------------------------- 1 | Created: 2009-04-15 10:02:06 UTC 2 | Depends: another_migration 3 | Apply: 4 | 5 | CREATE TABLE test ( 6 | a int 7 | ); 8 | 9 | Revert: DROP TABLE test; 10 | -------------------------------------------------------------------------------- /test/migration_parsing/valid_no_revert.txt: -------------------------------------------------------------------------------- 1 | Description: A valid full migration. 2 | Created: 2009-04-15 10:02:06 UTC 3 | Depends: another_migration 4 | Apply: 5 | 6 | CREATE TABLE test ( 7 | a int 8 | ); 9 | -------------------------------------------------------------------------------- /test/migration_parsing/valid_no_timestamp.txt: -------------------------------------------------------------------------------- 1 | Description: A valid full migration. 2 | Depends: another_migration 3 | Apply: 4 | 5 | CREATE TABLE test ( 6 | a int 7 | ); 8 | 9 | Revert: DROP TABLE test; 10 | -------------------------------------------------------------------------------- /test/example_store/root: -------------------------------------------------------------------------------- 1 | Description: The first migration in the store. 2 | Created: 2009-04-15 10:02:06 UTC 3 | Depends: 4 | Apply: 5 | 6 | CREATE TABLE test (a int); 7 | 8 | Revert: 9 | 10 | DROP TABLE test; 11 | -------------------------------------------------------------------------------- /test/migration_parsing/invalid_syntax.txt: -------------------------------------------------------------------------------- 1 | Description: The first migration in the store. 2 | Created: 2009-04-15 10:02:06 UTC 3 | Depends: valid 4 | Apply: 5 | CREATE TABLE test (a int); 6 | 7 | Revert: 8 | 9 | DROP TABLE test; 10 | -------------------------------------------------------------------------------- /test/migration_parsing/valid_no_depends.txt: -------------------------------------------------------------------------------- 1 | Description: A valid full migration. 2 | Created: 2009-04-15 10:02:06 UTC 3 | Depends: 4 | Apply: 5 | 6 | CREATE TABLE test ( 7 | a int 8 | ); 9 | 10 | Revert: DROP TABLE test; 11 | -------------------------------------------------------------------------------- /test/migration_parsing/invalid_timestamp.txt: -------------------------------------------------------------------------------- 1 | Description: The first migration in the store. 2 | Created: 209-41-15 :02:06 UTC 3 | Depends: valid 4 | Apply: 5 | 6 | CREATE TABLE test (a int); 7 | 8 | Revert: 9 | 10 | DROP TABLE test; 11 | -------------------------------------------------------------------------------- /test/example_store/update2: -------------------------------------------------------------------------------- 1 | Description: Add a constraint on test.b. 2 | Created: 2009-04-15 11:36:49 UTC 3 | Depends: update1 4 | Apply: 5 | 6 | CREATE UNIQUE INDEX test_b_idx ON test(b); 7 | 8 | Revert: 9 | 10 | DROP INDEX test_b_idx; 11 | -------------------------------------------------------------------------------- /test/migration_parsing/valid_full.txt: -------------------------------------------------------------------------------- 1 | Description: A valid full migration. 2 | Created: 2009-04-15 10:02:06 UTC 3 | Depends: another_migration 4 | Apply: 5 | 6 | CREATE TABLE test ( 7 | a int 8 | ); 9 | 10 | Revert: DROP TABLE test; 11 | -------------------------------------------------------------------------------- /test/example_store/update1: -------------------------------------------------------------------------------- 1 | Description: Add another meaningless column to test. 2 | Created: 2009-04-15 10:04:31 UTC 3 | Depends: root 4 | Apply: 5 | 6 | ALTER TABLE test ADD b int; 7 | 8 | Revert: 9 | 10 | ALTER TABLE test DROP COLUMN b; 11 | -------------------------------------------------------------------------------- /test/migration_parsing/invalid_field_name.txt: -------------------------------------------------------------------------------- 1 | Description: The first migration in the store. 2 | InvalidField: bogus 3 | Created: 2009-04-15 10:02:06 UTC 4 | Depends: valid 5 | Apply: 6 | 7 | CREATE TABLE test (a int); 8 | 9 | Revert: 10 | 11 | DROP TABLE test; 12 | -------------------------------------------------------------------------------- /test/migration_parsing/valid_with_multiline_deps.txt: -------------------------------------------------------------------------------- 1 | Description: A valid full migration. 2 | Created: 2009-04-15 10:02:06 UTC 3 | 4 | Depends: 5 | one 6 | two 7 | three 8 | 9 | Apply: 10 | 11 | CREATE TABLE test ( 12 | a int 13 | ); 14 | 15 | Revert: DROP TABLE test; 16 | -------------------------------------------------------------------------------- /test/migration_parsing/valid_with_colon.txt: -------------------------------------------------------------------------------- 1 | Description: A valid full migration. 2 | Created: 2009-04-15 10:02:06 UTC 3 | Depends: another_migration 4 | Apply: | 5 | 6 | -- Comment on a line with a colon: 7 | CREATE TABLE test ( 8 | a int 9 | ); 10 | 11 | Revert: DROP TABLE test; 12 | -------------------------------------------------------------------------------- /test/migration_parsing/valid_with_comments2.txt: -------------------------------------------------------------------------------- 1 | Description: A valid full migration. 2 | Created: 2009-04-15 10:02:06 UTC 3 | Depends: another_migration 4 | Apply: | 5 | 6 | -- Comment on a line 7 | CREATE TABLE test ( 8 | a int -- comment inline 9 | ); 10 | 11 | Revert: DROP TABLE test; 12 | -------------------------------------------------------------------------------- /test/migration_parsing/valid_with_comments.txt: -------------------------------------------------------------------------------- 1 | # This is a test migration. It includes all fields with valid values 2 | # and takes advantage of most parser corner-cases and features. 3 | 4 | Description: A valid full migration. 5 | Created: 2009-04-15 10:02:06 UTC 6 | Depends: another_migration 7 | Apply: 8 | 9 | CREATE TABLE test ( 10 | a int 11 | ); 12 | 13 | Revert: DROP TABLE test; 14 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # Do not choose a language; we provide our own build tools. 2 | language: generic 3 | 4 | before_install: 5 | - wget https://www.haskell.org/platform/download/8.4.3/haskell-platform-8.4.3-unknown-posix--full-x86_64.tar.gz 6 | - tar xf haskell-platform-8.4.3-unknown-posix--full-x86_64.tar.gz 7 | - sudo ./install-haskell-platform.sh 8 | - cabal --version 9 | 10 | install: 11 | - cabal update 12 | - cabal install --enable-tests 13 | 14 | script: 15 | - cabal test 16 | - cabal haddock 17 | -------------------------------------------------------------------------------- /programs/Moo.hs: -------------------------------------------------------------------------------- 1 | module Main 2 | ( main 3 | ) 4 | where 5 | 6 | import Prelude 7 | 8 | main :: IO () 9 | main = do 10 | error $ 11 | "This package (dbmigrations) does no longer contain the executable to \ 12 | \create, apply or revert database migrations. Please install the specific \ 13 | \wrapper package for your database: dbmigrations-postgresql, \ 14 | \dbmigrations-mysql, or dbmigrations-sqlite. These packages contain \ 15 | \database-specific executables that replace the former moo executable from the \ 16 | \dbmigrations package." 17 | 18 | -------------------------------------------------------------------------------- /test/CommonTH.hs: -------------------------------------------------------------------------------- 1 | module CommonTH 2 | ( getRepoRoot 3 | ) 4 | where 5 | 6 | import Language.Haskell.TH 7 | import System.FilePath ( takeDirectory, combine ) 8 | import System.Directory ( getCurrentDirectory, canonicalizePath ) 9 | 10 | getRepoRoot :: Q FilePath 11 | getRepoRoot = 12 | do here <- location 13 | cwd <- runIO getCurrentDirectory 14 | let thisFileName = combine cwd $ loc_filename here 15 | -- XXX: This depends on the location of this file in the source tree 16 | return =<< runIO $ canonicalizePath $ head $ drop 2 $ iterate takeDirectory thisFileName 17 | -------------------------------------------------------------------------------- /test/Common.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Common 3 | ( TestDependable(..) 4 | , repoRoot 5 | , testFile 6 | , satisfies 7 | , (.&&.) 8 | ) 9 | where 10 | 11 | import Data.Text ( Text ) 12 | 13 | import CommonTH 14 | import System.FilePath ( () ) 15 | import Language.Haskell.TH.Syntax (lift) 16 | import Test.HUnit 17 | 18 | import Database.Schema.Migrations.Dependencies ( Dependable(..) ) 19 | 20 | repoRoot :: FilePath 21 | repoRoot = $(getRepoRoot >>= lift) 22 | 23 | testFile :: FilePath -> FilePath 24 | testFile fp = repoRoot "test" fp 25 | 26 | instance Dependable TestDependable where 27 | depId = tdId 28 | depsOf = tdDeps 29 | 30 | data TestDependable = TD { tdId :: Text 31 | , tdDeps :: [Text] 32 | } 33 | deriving (Show, Eq, Ord) 34 | 35 | 36 | satisfies :: String -> a -> (a -> Bool) -> IO Test 37 | satisfies m v f = return $ TestCase $ assertBool m (f v) 38 | 39 | (.&&.) :: Test -> Test -> Test 40 | (TestList xs) .&&. (TestList ys) = TestList (xs ++ ys) 41 | (TestList xs) .&&. y = TestList (xs ++ [y]) 42 | x .&&. (TestList ys) = TestList (x:ys) 43 | a .&&. b = TestList [a, b] 44 | infixl 0 .&&. 45 | -------------------------------------------------------------------------------- /test/InMemoryStore.hs: -------------------------------------------------------------------------------- 1 | module InMemoryStore (inMemoryStore) where 2 | 3 | import Data.Text ( Text ) 4 | import Data.String.Conversions ( cs ) 5 | 6 | import Control.Concurrent.MVar 7 | import Database.Schema.Migrations.Migration 8 | import Database.Schema.Migrations.Store 9 | 10 | type InMemoryData = [(Text, Migration)] 11 | 12 | -- |Builds simple in-memory store that uses 'MVar' to preserve a list of 13 | -- migrations. 14 | inMemoryStore :: IO MigrationStore 15 | inMemoryStore = do 16 | store <- newMVar [] 17 | return MigrationStore { 18 | loadMigration = loadMigrationInMem store 19 | , saveMigration = saveMigrationInMem store 20 | , getMigrations = getMigrationsInMem store 21 | , fullMigrationName = return . cs 22 | } 23 | 24 | loadMigrationInMem :: MVar InMemoryData -> Text -> IO (Either String Migration) 25 | loadMigrationInMem store migId = withMVar store $ \migrations -> do 26 | let mig = lookup migId migrations 27 | return $ case mig of 28 | Just m -> Right m 29 | _ -> Left "Migration not found" 30 | 31 | saveMigrationInMem :: MVar InMemoryData -> Migration -> IO () 32 | saveMigrationInMem store m = modifyMVar_ store $ return . ((mId m, m):) 33 | 34 | getMigrationsInMem :: MVar InMemoryData -> IO [Text] 35 | getMigrationsInMem store = withMVar store $ return . fmap fst 36 | -------------------------------------------------------------------------------- /src/Database/Schema/Migrations/Migration.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Database.Schema.Migrations.Migration 3 | ( Migration(..) 4 | , newMigration 5 | , emptyMigration 6 | ) 7 | where 8 | 9 | import Database.Schema.Migrations.Dependencies 10 | 11 | import Data.Text ( Text ) 12 | import Data.Time () -- for UTCTime Show instance 13 | import qualified Data.Time.Clock as Clock 14 | 15 | data Migration = Migration { mTimestamp :: Maybe Clock.UTCTime 16 | , mId :: Text 17 | , mDesc :: Maybe Text 18 | , mApply :: Text 19 | , mRevert :: Maybe Text 20 | , mDeps :: [Text] 21 | } 22 | deriving (Eq, Show, Ord) 23 | 24 | instance Dependable Migration where 25 | depsOf = mDeps 26 | depId = mId 27 | 28 | emptyMigration :: Text -> Migration 29 | emptyMigration name = 30 | Migration { mTimestamp = Nothing 31 | , mId = name 32 | , mApply = "" 33 | , mRevert = Nothing 34 | , mDesc = Nothing 35 | , mDeps = [] 36 | } 37 | 38 | newMigration :: Text -> Migration 39 | newMigration theId = 40 | (emptyMigration theId) 41 | { mApply = "(Apply SQL here.)" 42 | , mDesc = Just "(Describe migration here.)" 43 | } 44 | -------------------------------------------------------------------------------- /test/FilesystemTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module FilesystemTest 3 | ( tests 4 | ) 5 | where 6 | 7 | import Database.Schema.Migrations.Filesystem 8 | import Database.Schema.Migrations.Store ( MigrationStore(..) ) 9 | 10 | import Test.HUnit 11 | import qualified Data.Set as Set 12 | import Common 13 | 14 | tests :: IO [Test] 15 | tests = sequence [getMigrationsTest] 16 | 17 | getMigrationsTest :: IO Test 18 | getMigrationsTest = do 19 | let store = filesystemStore $ FSStore { storePath = testFile "migration_parsing" } 20 | expected = Set.fromList [ "invalid_field_name" 21 | , "invalid_missing_required_fields" 22 | , "invalid_syntax" 23 | , "invalid_timestamp" 24 | , "valid_full" 25 | , "valid_no_depends" 26 | , "valid_no_desc" 27 | , "valid_no_revert" 28 | , "valid_no_timestamp" 29 | , "valid_with_comments" 30 | , "valid_with_comments2" 31 | , "valid_with_colon" 32 | , "valid_with_multiline_deps" 33 | ] 34 | migrations <- getMigrations store 35 | return $ expected ~=? Set.fromList migrations 36 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2009, Jonathan Daugherty. 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are 6 | met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * The names of the contributors may not be used to endorse or 17 | promote products derived from this software without specific 18 | prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | import Prelude 3 | import Test.HUnit 4 | import System.Exit 5 | import System.IO ( stderr ) 6 | 7 | import qualified DependencyTest 8 | import qualified MigrationsTest 9 | import qualified FilesystemSerializeTest 10 | import qualified FilesystemParseTest 11 | import qualified FilesystemTest 12 | import qualified CycleDetectionTest 13 | import qualified StoreTest 14 | import qualified LinearMigrationsTest 15 | import qualified ConfigurationTest 16 | 17 | import Control.Exception ( SomeException(..) ) 18 | 19 | loadTests :: IO [Test] 20 | loadTests = do 21 | 22 | ioTests <- sequence [ do fspTests <- FilesystemParseTest.tests 23 | return $ "Filesystem Parsing" ~: test fspTests 24 | , do fsTests <- FilesystemTest.tests 25 | return $ "Filesystem general" ~: test fsTests 26 | , do linTests <- LinearMigrationsTest.tests 27 | return $ "Linear migrations" ~: test linTests 28 | , do cfgTests <- ConfigurationTest.tests 29 | return $ "Configuration tests" ~: test cfgTests 30 | ] 31 | return $ concat [ ioTests 32 | , DependencyTest.tests 33 | , FilesystemSerializeTest.tests 34 | , MigrationsTest.tests 35 | , CycleDetectionTest.tests 36 | , StoreTest.tests 37 | ] 38 | 39 | tempDatabase :: String 40 | tempDatabase = "dbmigrations_test" 41 | 42 | ignoreException :: SomeException -> IO () 43 | ignoreException _ = return () 44 | 45 | main :: IO () 46 | main = do 47 | tests <- loadTests 48 | (testResults, _) <- runTestText (putTextToHandle stderr False) $ test tests 49 | if errors testResults + failures testResults > 0 50 | then exitFailure 51 | else exitSuccess 52 | -------------------------------------------------------------------------------- /src/Database/Schema/Migrations/CycleDetection.hs: -------------------------------------------------------------------------------- 1 | module Database.Schema.Migrations.CycleDetection 2 | ( hasCycle 3 | ) 4 | where 5 | 6 | import Data.Graph.Inductive.Graph 7 | ( Graph(..) 8 | , Node 9 | , nodes 10 | , edges 11 | ) 12 | 13 | import Control.Monad.State ( State, evalState, gets, get, put ) 14 | import Control.Monad ( forM ) 15 | 16 | import Data.Maybe ( fromJust ) 17 | import Data.List ( findIndex ) 18 | 19 | data Mark = White | Gray | Black 20 | type CycleDetectionState = [(Node, Mark)] 21 | 22 | -- Cycle detection algorithm taken from http://www.cs.berkeley.edu/~kamil/teaching/sp03/041403.pdf 23 | hasCycle :: Graph g => g a b -> Bool 24 | hasCycle g = evalState (hasCycle' g) [(n, White) | n <- nodes g] 25 | 26 | getMark :: Int -> State CycleDetectionState Mark 27 | getMark n = gets (fromJust . lookup n) 28 | 29 | replace :: [a] -> Int -> a -> [a] 30 | replace elems index val 31 | | index > length elems = error "replacement index too large" 32 | | otherwise = (take index elems) ++ 33 | [val] ++ 34 | (reverse $ take ((length elems) - (index + 1)) $ reverse elems) 35 | 36 | setMark :: Int -> Mark -> State CycleDetectionState () 37 | setMark n mark = do 38 | st <- get 39 | let index = fromJust $ findIndex (\(n', _) -> n' == n) st 40 | put $ replace st index (n, mark) 41 | 42 | hasCycle' :: Graph g => g a b -> State CycleDetectionState Bool 43 | hasCycle' g = do 44 | result <- forM (nodes g) $ \n -> do 45 | m <- getMark n 46 | case m of 47 | White -> visit g n 48 | _ -> return False 49 | return $ or result 50 | 51 | visit :: Graph g => g a b -> Node -> State CycleDetectionState Bool 52 | visit g n = do 53 | setMark n Gray 54 | result <- forM [ v | (u,v) <- edges g, u == n ] $ \node -> do 55 | m <- getMark node 56 | case m of 57 | Gray -> return True 58 | White -> visit g node 59 | _ -> return False 60 | case or result of 61 | True -> return True 62 | False -> do 63 | setMark n Black 64 | return False 65 | -------------------------------------------------------------------------------- /test/CycleDetectionTest.hs: -------------------------------------------------------------------------------- 1 | module CycleDetectionTest 2 | ( tests 3 | ) 4 | where 5 | 6 | import Test.HUnit 7 | import Data.Graph.Inductive.PatriciaTree ( Gr ) 8 | import Data.Graph.Inductive.Graph ( mkGraph ) 9 | 10 | import Database.Schema.Migrations.CycleDetection 11 | 12 | tests :: [Test] 13 | tests = mkCycleTests 14 | 15 | noCycles :: Gr String String 16 | noCycles = mkGraph [(1,"one"),(2,"two")] [(1,2,"one->two")] 17 | 18 | noCyclesEmpty :: Gr String String 19 | noCyclesEmpty = mkGraph [] [] 20 | 21 | withCycleSimple :: Gr String String 22 | withCycleSimple = mkGraph [(1,"one")] [(1,1,"one->one")] 23 | 24 | withCycleComplex :: Gr String String 25 | withCycleComplex = mkGraph [(1,"one"),(2,"two"),(3,"three"),(4,"four")] 26 | [(4,1,"four->one"),(1,2,"one->two"),(2,3,"two->three"),(3,1,"three->one")] 27 | 28 | withCycleRadial :: Gr String String 29 | withCycleRadial = mkGraph [(1,"one"),(2,"two"),(3,"three"),(4,"four")] 30 | [(2,1,""),(2,3,""),(3,4,""),(3,2,"")] 31 | 32 | noCycleRadial :: Gr String String 33 | noCycleRadial = mkGraph [(1,""),(2,""),(3,""),(4,"")] 34 | [(1,2,""),(3,1,""),(4,1,"")] 35 | 36 | -- This graph would contain a loop if it were undirected, but it does 37 | -- not contain a directed cycle. 38 | noDirectedCycle1 :: Gr String String 39 | noDirectedCycle1 = mkGraph [(1,""),(2,""),(3,""),(4,"")] 40 | [(1,2,""),(1,3,""),(3,2,""),(2,4,"")] 41 | 42 | -- This graph would contain a loop if it were undirected, but it does 43 | -- not contain a directed cycle. 44 | noDirectedCycle2 :: Gr String String 45 | noDirectedCycle2 = mkGraph [(1,"flub"),(2,"test.db"),(3,"test2"),(4,"test3"),(5,"test1")] 46 | [ (1,2,"flub->test.db") 47 | , (2,3,"test.db->test2") 48 | , (2,4,"test.db->test3") 49 | , (3,5,"test2->test1") 50 | , (4,3,"test3->test2") 51 | ] 52 | 53 | type CycleTestCase = (Gr String String, Bool) 54 | 55 | cycleTests :: [CycleTestCase] 56 | cycleTests = [ (noCyclesEmpty, False) 57 | , (noCycles, False) 58 | , (noCycleRadial, False) 59 | , (withCycleSimple, True) 60 | , (withCycleComplex, True) 61 | , (withCycleRadial, True) 62 | , (noDirectedCycle1, False) 63 | , (noDirectedCycle2, False) 64 | ] 65 | 66 | mkCycleTests :: [Test] 67 | mkCycleTests = map mkCycleTest cycleTests 68 | where 69 | mkCycleTest (g, expected) = expected ~=? hasCycle g 70 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | Stability Note 3 | -------------- 4 | 5 | Warning: this package is no longer actively maintained, and 6 | unfortunately I do not have plans to resume maintenance. This package 7 | is very old; in fact, it's the first Haskell package I published, and 8 | it shows in many ways. I also don't use it nowadays, which doesn't 9 | help when it comes to maintenance. If you are using this library in 10 | production, just keep this in mind and I encourage you to consider 11 | alternatives. If you would like to take over maintenance, please 12 | consider forking this and letting me know at `cygnus AT foobox DOT com` 13 | so I can update the Hackage deprecation status in favor of your new 14 | package. 15 | 16 | dbmigrations 17 | ------------ 18 | 19 | This package contains a library for the creation, management, and 20 | installation of schema updates (called "migrations") for a relational 21 | database. In particular, this package lets the migration author express 22 | explicit dependencies between migrations. This library is accompanied 23 | by a number database-specific packages that contain the management 24 | tools to automatically install or revert migrations accordingly. 25 | 26 | This package operates on two logical entities: 27 | 28 | - The "backend": the relational database whose schema you want to 29 | manage. 30 | 31 | - The "migration store": the collection of schema changes you want to 32 | apply to the database. These migrations are expressed using plain 33 | text files collected together in a single directory, although the 34 | library is general enough to permit easy implementation of other 35 | storage representations for migrations. 36 | 37 | Getting started 38 | --------------- 39 | 40 | To get started, install the right database-specific dbmigrations package 41 | for your database. Current options are: 42 | 43 | * `dbmigrations-postgresql` 44 | * `dbmigrations-mysql` 45 | * `dbmigrations-sqlite` 46 | 47 | Each package provides a variant of the "moo" management program 48 | ("moo-postgresql", "moo-mysql", and "moo-sqlite" respectively) to be 49 | used to manage your database schema. See MOO.TXT for details on how to 50 | use these tools to manage your database migrations. 51 | 52 | Submitting patches 53 | ------------------ 54 | 55 | I'll gladly consider accepting patches to this package; please do not 56 | hesitate to submit GitHub pull requests. I'll be more likely to accept 57 | a patch if you can follow these guidelines where appropriate: 58 | 59 | - Keep patches small; a single patch should make a single logical 60 | change with minimal scope. 61 | 62 | - If possible, include tests with your patch. 63 | 64 | - If possible, include haddock with your patch. 65 | -------------------------------------------------------------------------------- /src/Database/Schema/Migrations/Filesystem/Serialize.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Database.Schema.Migrations.Filesystem.Serialize 3 | ( serializeMigration 4 | ) 5 | where 6 | 7 | import Data.ByteString ( ByteString ) 8 | import qualified Data.ByteString as BS 9 | import Data.Text ( Text ) 10 | import qualified Data.Text as T 11 | import Data.String.Conversions ( cs ) 12 | import Data.Time () -- for UTCTime Show instance 13 | import Data.Maybe ( catMaybes ) 14 | import Data.Monoid ( (<>) ) 15 | 16 | import Database.Schema.Migrations.Migration 17 | ( Migration(..) 18 | ) 19 | 20 | type FieldSerializer = Migration -> Maybe ByteString 21 | 22 | fieldSerializers :: [FieldSerializer] 23 | fieldSerializers = [ serializeDesc 24 | , serializeTimestamp 25 | , serializeDepends 26 | , serializeApply 27 | , serializeRevert 28 | ] 29 | 30 | serializeDesc :: FieldSerializer 31 | serializeDesc m = 32 | case mDesc m of 33 | Nothing -> Nothing 34 | Just desc -> Just . cs $ "Description: " <> desc 35 | 36 | serializeTimestamp :: FieldSerializer 37 | serializeTimestamp m = 38 | case mTimestamp m of 39 | Nothing -> Nothing 40 | Just ts -> Just $ "Created: " <> (cs . show $ ts) 41 | 42 | serializeDepends :: FieldSerializer 43 | serializeDepends m = Just . cs $ "Depends: " <> (T.intercalate " " $ mDeps m) 44 | 45 | serializeRevert :: FieldSerializer 46 | serializeRevert m = 47 | case mRevert m of 48 | Nothing -> Nothing 49 | Just revert -> Just $ "Revert: |\n" <> 50 | (serializeMultiline revert) 51 | 52 | serializeApply :: FieldSerializer 53 | serializeApply m = Just $ "Apply: |\n" <> (serializeMultiline $ mApply m) 54 | 55 | commonPrefix :: Text -> Text -> Text 56 | commonPrefix a b = cs . map fst $ takeWhile (uncurry (==)) (T.zip a b) 57 | 58 | commonPrefixLines :: [Text] -> Text 59 | commonPrefixLines [] = "" 60 | commonPrefixLines theLines = foldl1 commonPrefix theLines 61 | 62 | serializeMultiline :: Text -> ByteString 63 | serializeMultiline s = 64 | let sLines = T.lines s 65 | prefix = case T.head $ commonPrefixLines sLines of 66 | -- If the lines already have a common prefix that 67 | -- begins with whitespace, no new prefix is 68 | -- necessary. 69 | ' ' -> "" 70 | -- Otherwise, use a new prefix of two spaces. 71 | _ -> " " 72 | 73 | in cs . T.unlines $ map (prefix <>) sLines 74 | 75 | serializeMigration :: Migration -> ByteString 76 | serializeMigration m = BS.intercalate "\n" fields 77 | where 78 | fields = catMaybes [ f m | f <- fieldSerializers ] 79 | -------------------------------------------------------------------------------- /src/Database/Schema/Migrations/Backend/HDBC.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Database.Schema.Migrations.Backend.HDBC 3 | ( hdbcBackend 4 | ) 5 | where 6 | 7 | import Database.HDBC 8 | ( quickQuery' 9 | , fromSql 10 | , toSql 11 | , IConnection(getTables, run, runRaw) 12 | , commit 13 | , rollback 14 | , disconnect 15 | ) 16 | 17 | import Database.Schema.Migrations.Backend 18 | ( Backend(..) 19 | , rootMigrationName 20 | ) 21 | import Database.Schema.Migrations.Migration 22 | ( Migration(..) 23 | , newMigration 24 | ) 25 | 26 | import Data.Text ( Text ) 27 | import Data.String.Conversions ( cs, (<>) ) 28 | 29 | import Control.Applicative ( (<$>) ) 30 | import Data.Time.Clock (getCurrentTime) 31 | 32 | migrationTableName :: Text 33 | migrationTableName = "installed_migrations" 34 | 35 | createSql :: Text 36 | createSql = "CREATE TABLE " <> migrationTableName <> " (migration_id TEXT)" 37 | 38 | revertSql :: Text 39 | revertSql = "DROP TABLE " <> migrationTableName 40 | 41 | -- |General Backend constructor for all HDBC connection implementations. 42 | hdbcBackend :: (IConnection conn) => conn -> Backend 43 | hdbcBackend conn = 44 | Backend { isBootstrapped = elem (cs migrationTableName) <$> getTables conn 45 | , getBootstrapMigration = 46 | do 47 | ts <- getCurrentTime 48 | return $ (newMigration rootMigrationName) 49 | { mApply = createSql 50 | , mRevert = Just revertSql 51 | , mDesc = Just "Migration table installation" 52 | , mTimestamp = Just ts 53 | } 54 | 55 | , applyMigration = \m -> do 56 | runRaw conn (cs $ mApply m) 57 | _ <- run conn (cs $ "INSERT INTO " <> migrationTableName <> 58 | " (migration_id) VALUES (?)") [toSql $ mId m] 59 | return () 60 | 61 | , revertMigration = \m -> do 62 | case mRevert m of 63 | Nothing -> return () 64 | Just query -> runRaw conn (cs query) 65 | -- Remove migration from installed_migrations in either case. 66 | _ <- run conn (cs $ "DELETE FROM " <> migrationTableName <> 67 | " WHERE migration_id = ?") [toSql $ mId m] 68 | return () 69 | 70 | , getMigrations = do 71 | results <- quickQuery' conn (cs $ "SELECT migration_id FROM " <> migrationTableName) [] 72 | return $ map (fromSql . head) results 73 | 74 | , commitBackend = commit conn 75 | 76 | , rollbackBackend = rollback conn 77 | 78 | , disconnectBackend = disconnect conn 79 | } 80 | -------------------------------------------------------------------------------- /test/MigrationsTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeSynonymInstances,GeneralizedNewtypeDeriving,MultiParamTypeClasses,FlexibleInstances,OverloadedStrings #-} 2 | module MigrationsTest 3 | ( tests 4 | ) 5 | where 6 | 7 | import Test.HUnit 8 | import Control.Applicative ((<$>)) 9 | import qualified Data.Map as Map 10 | import Data.Time.Clock ( UTCTime ) 11 | 12 | import Database.Schema.Migrations 13 | import Database.Schema.Migrations.Store hiding (getMigrations) 14 | import Database.Schema.Migrations.Migration 15 | import Database.Schema.Migrations.Backend 16 | 17 | tests :: [Test] 18 | tests = migrationsToApplyTests 19 | 20 | testBackend :: [Migration] -> Backend 21 | testBackend testMs = 22 | Backend { getBootstrapMigration = undefined 23 | , isBootstrapped = return True 24 | , applyMigration = const undefined 25 | , revertMigration = const undefined 26 | , getMigrations = return $ mId <$> testMs 27 | , commitBackend = return () 28 | , rollbackBackend = return () 29 | , disconnectBackend = return () 30 | } 31 | 32 | -- |Given a backend and a store, what are the list of migrations 33 | -- missing in the backend that are available in the store? 34 | type MissingMigrationTestCase = (MigrationMap, Backend, Migration, 35 | [Migration]) 36 | 37 | ts :: UTCTime 38 | ts = read "2009-04-15 10:02:06 UTC" 39 | 40 | blankMigration :: Migration 41 | blankMigration = Migration { mTimestamp = Just ts 42 | , mId = undefined 43 | , mDesc = Nothing 44 | , mApply = "" 45 | , mRevert = Nothing 46 | , mDeps = [] 47 | } 48 | 49 | missingMigrationsTestcases :: [MissingMigrationTestCase] 50 | missingMigrationsTestcases = [ (m, testBackend [], one, [one]) 51 | , (m, testBackend [one], one, []) 52 | , (m, testBackend [one], two, [two]) 53 | , (m, testBackend [one, two], one, []) 54 | , (m, testBackend [one, two], two, []) 55 | ] 56 | where 57 | one = blankMigration { mId = "one" } 58 | two = blankMigration { mId = "two", mDeps = ["one"] } 59 | m = Map.fromList [ (mId e, e) | e <- [one, two] ] 60 | 61 | mkTest :: MissingMigrationTestCase -> Test 62 | mkTest (mapping, backend, theMigration, expected) = 63 | let Right graph = depGraphFromMapping mapping 64 | storeData = StoreData mapping graph 65 | result = migrationsToApply storeData backend theMigration 66 | in "a test" ~: do 67 | actual <- result 68 | return $ expected == actual 69 | 70 | migrationsToApplyTests :: [Test] 71 | migrationsToApplyTests = map mkTest missingMigrationsTestcases 72 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | 2 | 2.1.0 3 | ----- 4 | 5 | Package changes: 6 | - Migrated from `yaml-light` to `yaml` package for YAML parsing (thanks 7 | Hank Levsen ) 8 | 9 | Other changes: 10 | - `Text` is now used instead of `String` in most parts of the codebase 11 | (thanks Vitalii Guzeev ) 12 | - New migrations now get the `.yml` file extension, but old migration 13 | `txt` files are also supported. 14 | 15 | 2.0.0 16 | ----- 17 | 18 | This release contains breaking changes! 19 | 20 | - Factored out all database-specific functionality into separate 21 | packages (thanks Bastian Krol) 22 | - Replaced "moo" program with one that emits an error instructing users 23 | to use backend-specific dbmigrations packages 24 | - Added missing test data files to package 25 | - Removed `DBM_DATABASE_TYPE` environment variable in favor of backend 26 | selection by use of backend-specific packages 27 | - Allow `DBM_TIMESTAMP_FILENAMES` to be set via environment variable 28 | (thanks Alexander Lippling) 29 | 30 | 1.1.1 31 | ----- 32 | 33 | - Improve configuration validation error messages and clean up 34 | validation routine 35 | - Reinstate support for GHC 7.8 36 | 37 | 1.1 38 | --- 39 | 40 | - Add support for MySQL databases (thanks Ollie Charles 41 | ). Please see MOO.TXT for a disclaimer about this 42 | feature! 43 | 44 | 1.0 45 | --- 46 | 47 | - Added support for (optionally) adding timestamps to generated 48 | migration filenames (thanks Matt Parsons ) 49 | * Adds flag for time stamp on file names 50 | * Adds configuration for timestamping filenames 51 | - Added new "linear migrations" feature (thanks Jakub Fijałkowski 52 | , Andrew Martin ). This 53 | feature is an optional alternative to the default behavior: rather than 54 | prompting the user for dependencies of new migrations (the default 55 | behavior), linear mode automatically selects dependencies for new 56 | migrations such that they depend on the smallest subset of migrations 57 | necessary to (effectively) depend on all existing migrations, thus 58 | "linearizing" the migration sequence. See MOO.TXT for details. 59 | - Configuration file loading now defaults to "moo.cfg" in the CWD if 60 | --config-file is not specified, and environment variables override 61 | settings in the config file 62 | 63 | 0.9.1 64 | ----- 65 | 66 | - Restored default timestamp and description values in migrations 67 | created by new migration command 68 | 69 | 0.9 70 | --- 71 | 72 | - Fix 'moo' usage output to use correct program name 73 | - Replaced Backend type class in favor of concrete Backend record type 74 | - Added hdbcBackend constructor 75 | - Backends now always run in IO rather than some MonadIO 76 | - Removed monad parameter from MigrationStore (always use IO) 77 | - Replaced MigrationStore type class with concrete MigrationStore type 78 | - Added filesystem migration store constructor 79 | - Improve configuration type so that it has been implicitly validated 80 | - Made newMigration pure, made migration timestamps optional 81 | - createNewMigration now takes a Migration for greater caller control 82 | -------------------------------------------------------------------------------- /test/FilesystemSerializeTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module FilesystemSerializeTest 3 | ( tests 4 | ) 5 | where 6 | 7 | import Test.HUnit 8 | import Data.ByteString ( ByteString ) 9 | import Data.String.Conversions ( (<>), cs ) 10 | import Data.Time.Clock ( UTCTime ) 11 | 12 | import Database.Schema.Migrations.Filesystem.Serialize 13 | import Database.Schema.Migrations.Migration 14 | 15 | tests :: [Test] 16 | tests = serializationTests 17 | 18 | mkSerializationTest :: (Migration, ByteString) -> Test 19 | mkSerializationTest (m, expectedString) = test $ expectedString ~=? serializeMigration m 20 | 21 | tsStr :: String 22 | tsStr = "2009-04-15 10:02:06 UTC" 23 | 24 | ts :: UTCTime 25 | ts = read tsStr 26 | 27 | valid_full :: Migration 28 | valid_full = Migration { 29 | mTimestamp = Just ts 30 | , mId = "valid_full" 31 | , mDesc = Just "A valid full migration." 32 | , mDeps = ["another_migration"] 33 | , mApply = " CREATE TABLE test (\n a int\n );\n" 34 | , mRevert = Just "DROP TABLE test;" 35 | } 36 | 37 | serializationTestCases :: [(Migration, ByteString)] 38 | serializationTestCases = [ (valid_full, cs $ "Description: A valid full migration.\n\ 39 | \Created: " <> tsStr <> "\n\ 40 | \Depends: another_migration\n\ 41 | \Apply: |\n\ 42 | \ CREATE TABLE test (\n\ 43 | \ a int\n\ 44 | \ );\n\n\ 45 | \Revert: |\n\ 46 | \ DROP TABLE test;\n") 47 | , (valid_full { mDesc = Nothing } 48 | , cs $ "Created: " <> tsStr <> "\n\ 49 | \Depends: another_migration\n\ 50 | \Apply: |\n\ 51 | \ CREATE TABLE test (\n\ 52 | \ a int\n\ 53 | \ );\n\n\ 54 | \Revert: |\n\ 55 | \ DROP TABLE test;\n") 56 | , (valid_full { mDeps = ["one", "two"] } 57 | , cs $ "Description: A valid full migration.\n\ 58 | \Created: " <> tsStr <> "\n\ 59 | \Depends: one two\n\ 60 | \Apply: |\n\ 61 | \ CREATE TABLE test (\n\ 62 | \ a int\n\ 63 | \ );\n\n\ 64 | \Revert: |\n\ 65 | \ DROP TABLE test;\n") 66 | , (valid_full { mRevert = Nothing } 67 | , cs $ "Description: A valid full migration.\n\ 68 | \Created: " <> tsStr <> "\n\ 69 | \Depends: another_migration\n\ 70 | \Apply: |\n\ 71 | \ CREATE TABLE test (\n\ 72 | \ a int\n\ 73 | \ );\n") 74 | ] 75 | 76 | serializationTests :: [Test] 77 | serializationTests = map mkSerializationTest serializationTestCases 78 | -------------------------------------------------------------------------------- /src/Database/Schema/Migrations/Backend.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Database.Schema.Migrations.Backend 3 | ( Backend(..) 4 | , rootMigrationName 5 | ) 6 | where 7 | 8 | import Data.Text ( Text ) 9 | 10 | import Database.Schema.Migrations.Migration 11 | ( Migration(..) ) 12 | 13 | -- |Backend instances should use this as the name of the migration 14 | -- returned by getBootstrapMigration; this migration is special 15 | -- because it cannot be reverted. 16 | rootMigrationName :: Text 17 | rootMigrationName = "root" 18 | 19 | -- |A Backend represents a database engine backend such as MySQL or 20 | -- SQLite. A Backend supplies relatively low-level functions for 21 | -- inspecting the backend's state, applying migrations, and reverting 22 | -- migrations. A Backend also supplies the migration necessary to 23 | -- "bootstrap" a backend so that it can track which migrations are 24 | -- installed. 25 | data Backend = 26 | Backend { getBootstrapMigration :: IO Migration 27 | -- ^ The migration necessary to bootstrap a database with 28 | -- this connection interface. This might differ slightly 29 | -- from one backend to another. 30 | 31 | , isBootstrapped :: IO Bool 32 | -- ^ Returns whether the backend has been bootstrapped. A 33 | -- backend has been bootstrapped if is capable of tracking 34 | -- which migrations have been installed; the "bootstrap 35 | -- migration" provided by getBootstrapMigration should 36 | -- suffice to bootstrap the backend. 37 | 38 | , applyMigration :: Migration -> IO () 39 | -- ^ Apply the specified migration on the backend. 40 | -- applyMigration does NOT assume control of the 41 | -- transaction, since it expects the transaction to 42 | -- (possibly) cover more than one applyMigration operation. 43 | -- The caller is expected to call commit at the appropriate 44 | -- time. If the application fails, the underlying SqlError 45 | -- is raised and a manual rollback may be necessary; for 46 | -- this, see withTransaction from HDBC. 47 | 48 | , revertMigration :: Migration -> IO () 49 | -- ^ Revert the specified migration from the backend and 50 | -- record this action in the table which tracks installed 51 | -- migrations. revertMigration does NOT assume control of 52 | -- the transaction, since it expects the transaction to 53 | -- (possibly) cover more than one revertMigration operation. 54 | -- The caller is expected to call commit at the appropriate 55 | -- time. If the revert fails, the underlying SqlError is 56 | -- raised and a manual rollback may be necessary; for this, 57 | -- see withTransaction from HDBC. If the specified migration 58 | -- does not supply a revert instruction, this has no effect 59 | -- other than bookkeeping. 60 | 61 | , getMigrations :: IO [Text] 62 | -- ^ Returns a list of installed migration names from the 63 | -- backend. 64 | 65 | , commitBackend :: IO () 66 | -- ^ Commit changes to the backend. 67 | 68 | , rollbackBackend :: IO () 69 | -- ^ Revert changes made to the backend since the current 70 | -- transaction began. 71 | 72 | , disconnectBackend :: IO () 73 | -- ^ Disconnect from the backend. 74 | } 75 | 76 | instance Show Backend where 77 | show _ = "dbmigrations backend" 78 | -------------------------------------------------------------------------------- /test/ConfigurationTest.hs: -------------------------------------------------------------------------------- 1 | module ConfigurationTest (tests) where 2 | 3 | import Control.Exception (SomeException, try) 4 | import Data.Either (isLeft, isRight) 5 | import System.Directory 6 | import System.Environment (setEnv, unsetEnv) 7 | import Test.HUnit 8 | 9 | import Common 10 | import Moo.Core 11 | 12 | tests :: IO [Test] 13 | tests = sequence [prepareTestEnv >> e | e <- entries] 14 | where entries = [ loadsConfigFile 15 | , loadsPropertiesFromFile 16 | , loadsDefaultConfigFile 17 | , environmentOverridesProperties 18 | , ifNoConfigFileIsAvailableEnvironmentIsUsed 19 | , throwsWhenConfigFileIsInvalid 20 | , returnsErrorWhenNotAllPropertiesAreSet 21 | , canReadTimestampsConfig 22 | ] 23 | 24 | prepareTestEnv :: IO () 25 | prepareTestEnv = do 26 | setCurrentDirectory $ testFile "config_loading" 27 | unsetEnv "DBM_DATABASE" 28 | unsetEnv "DBM_MIGRATION_STORE" 29 | unsetEnv "DBM_LINEAR_MIGRATIONS" 30 | unsetEnv "DBM_TIMESTAMP_FILENAMES" 31 | 32 | canReadTimestampsConfig :: IO Test 33 | canReadTimestampsConfig = do 34 | Right cfg <- loadConfiguration (Just "cfg_ts.cfg") 35 | satisfies "Timestamp not set" cfg _timestampFilenames 36 | 37 | loadsConfigFile :: IO Test 38 | loadsConfigFile = do 39 | cfg' <- loadConfiguration (Just "cfg1.cfg") 40 | satisfies "File not loaded" cfg' isRight 41 | 42 | loadsPropertiesFromFile :: IO Test 43 | loadsPropertiesFromFile = do 44 | Right cfg <- loadConfiguration (Just "cfg1.cfg") 45 | return 46 | ( 47 | _connectionString cfg ~?= "connection" .&&. 48 | _migrationStorePath cfg ~?= "store" .&&. 49 | _linearMigrations cfg ~?= True 50 | ) 51 | 52 | loadsDefaultConfigFile :: IO Test 53 | loadsDefaultConfigFile = do 54 | Right cfg <- loadConfiguration Nothing 55 | return 56 | ( 57 | _connectionString cfg ~?= "mooconn" .&&. 58 | _migrationStorePath cfg ~?= "moostore" .&&. 59 | _linearMigrations cfg ~?= True 60 | ) 61 | 62 | environmentOverridesProperties :: IO Test 63 | environmentOverridesProperties = do 64 | setEnv "DBM_DATABASE" "envconn" 65 | setEnv "DBM_MIGRATION_STORE" "envstore" 66 | setEnv "DBM_LINEAR_MIGRATIONS" "off" 67 | Right cfg <- loadConfiguration (Just "cfg1.cfg") 68 | return 69 | ( 70 | _connectionString cfg ~?= "envconn" .&&. 71 | _migrationStorePath cfg ~?= "envstore" .&&. 72 | _linearMigrations cfg ~?= False 73 | ) 74 | 75 | ifNoConfigFileIsAvailableEnvironmentIsUsed :: IO Test 76 | ifNoConfigFileIsAvailableEnvironmentIsUsed = do 77 | setCurrentDirectory $ testFile "" 78 | setEnv "DBM_DATABASE" "envconn" 79 | setEnv "DBM_MIGRATION_STORE" "envstore" 80 | setEnv "DBM_LINEAR_MIGRATIONS" "off" 81 | Right cfg <- loadConfiguration Nothing 82 | return 83 | ( 84 | _connectionString cfg ~?= "envconn" .&&. 85 | _migrationStorePath cfg ~?= "envstore" .&&. 86 | _linearMigrations cfg ~?= False 87 | ) 88 | 89 | returnsErrorWhenNotAllPropertiesAreSet :: IO Test 90 | returnsErrorWhenNotAllPropertiesAreSet = do 91 | cfg <- loadConfiguration (Just "missing.cfg") 92 | satisfies "Should return error" cfg isLeft 93 | 94 | throwsWhenConfigFileIsInvalid :: IO Test 95 | throwsWhenConfigFileIsInvalid = do 96 | c <- try $ loadConfiguration (Just "invalid.cfg") 97 | satisfies "Should throw" c (isLeft :: Either SomeException a -> Bool) 98 | -------------------------------------------------------------------------------- /src/Moo/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Moo.Main 3 | ( mainWithParameters 4 | , ExecutableParameters (..) 5 | , Configuration (..) 6 | , Args 7 | , usage 8 | , usageSpecific 9 | , procArgs 10 | ) 11 | where 12 | 13 | import Control.Monad.Reader (forM_, runReaderT, when) 14 | import Database.HDBC (SqlError, catchSql, seErrorMsg) 15 | import Prelude hiding (lookup) 16 | import Data.Text (Text) 17 | import Data.String.Conversions (cs) 18 | import System.Environment (getProgName) 19 | import System.Exit (ExitCode (ExitFailure), exitWith) 20 | 21 | import Database.Schema.Migrations.Filesystem (filesystemStore, FilesystemStoreSettings(..)) 22 | import Database.Schema.Migrations.Store 23 | import Moo.CommandInterface 24 | import Moo.Core 25 | 26 | type Args = [String] 27 | 28 | usage :: IO a 29 | usage = do 30 | progName <- getProgName 31 | 32 | putStrLn $ "Usage: " ++ progName ++ " [args]" 33 | putStrLn "Environment:" 34 | putStrLn $ " " ++ envDatabaseName ++ ": database connection string" 35 | putStrLn $ " " ++ envStoreName ++ ": path to migration store" 36 | putStrLn $ " " ++ envLinearMigrations ++ ": whether to use linear migrations (defaults to False)" 37 | putStrLn "Commands:" 38 | forM_ commands $ \command -> do 39 | putStrLn $ " " ++ usageString command 40 | putStrLn $ " " ++ _cDescription command 41 | putStrLn "" 42 | 43 | putStrLn commandOptionUsage 44 | exitWith (ExitFailure 1) 45 | 46 | usageSpecific :: Command -> IO a 47 | usageSpecific command = do 48 | pn <- getProgName 49 | putStrLn $ "Usage: " ++ pn ++ " " ++ usageString command 50 | exitWith (ExitFailure 1) 51 | 52 | procArgs :: Args -> IO (Command, CommandOptions, [String]) 53 | procArgs args = do 54 | when (null args) usage 55 | 56 | command <- case findCommand $ head args of 57 | Nothing -> usage 58 | Just c -> return c 59 | 60 | (opts, required) <- getCommandArgs $ tail args 61 | 62 | return (command, opts, required) 63 | 64 | mainWithParameters :: Args -> ExecutableParameters -> IO () 65 | mainWithParameters args parameters = do 66 | (command, opts, required) <- procArgs args 67 | 68 | let storePathStr = _parametersMigrationStorePath parameters 69 | store = filesystemStore $ FSStore { storePath = storePathStr } 70 | linear = _parametersLinearMigrations parameters 71 | 72 | if length required < length ( _cRequired command) then 73 | usageSpecific command else 74 | do 75 | loadedStoreData <- loadMigrations store 76 | case loadedStoreData of 77 | Left es -> do 78 | putStrLn "There were errors in the migration store:" 79 | forM_ es $ \err -> putStrLn $ " " ++ show err 80 | Right storeData -> do 81 | let st = AppState { _appOptions = opts 82 | , _appCommand = command 83 | , _appRequiredArgs = map cs required 84 | , _appOptionalArgs = ["" :: Text] 85 | , _appBackend = _parametersBackend parameters 86 | , _appStore = store 87 | , _appStoreData = storeData 88 | , _appLinearMigrations = linear 89 | , _appTimestampFilenames = 90 | _parametersTimestampFilenames parameters 91 | } 92 | runReaderT (_cHandler command storeData) st `catchSql` reportSqlError 93 | 94 | reportSqlError :: SqlError -> IO a 95 | reportSqlError e = do 96 | putStrLn $ "\n" ++ "A database error occurred: " ++ seErrorMsg e 97 | exitWith (ExitFailure 1) 98 | -------------------------------------------------------------------------------- /test/LinearMigrationsTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module LinearMigrationsTest (tests) where 3 | 4 | import InMemoryStore 5 | import Test.HUnit 6 | 7 | import Common 8 | import Control.Monad.Reader (runReaderT) 9 | import Data.Text (Text) 10 | import Data.Either (isRight) 11 | import Database.Schema.Migrations.Migration 12 | import Database.Schema.Migrations.Store 13 | import Moo.CommandHandlers 14 | import Moo.Core 15 | 16 | tests :: IO [Test] 17 | tests = sequence [ addsMigration 18 | , selectsLatestMigrationAsDep 19 | , selectsOnlyLeavesAsDeps 20 | , doesNotAddDependencyWhenLinearMigrationsAreDisabled 21 | ] 22 | 23 | addsMigration :: IO Test 24 | addsMigration = do 25 | state <- prepareState "first" 26 | mig <- addTestMigration state 27 | satisfies "Migration not added" mig isRight 28 | 29 | selectsLatestMigrationAsDep :: IO Test 30 | selectsLatestMigrationAsDep = do 31 | state1 <- prepareState "first" 32 | _ <- addTestMigration state1 33 | state2 <- prepareStateWith state1 "second" 34 | Right mig <- addTestMigration state2 35 | return $ ["first"] ~=? mDeps mig 36 | 37 | selectsOnlyLeavesAsDeps :: IO Test 38 | selectsOnlyLeavesAsDeps = do 39 | state1 <- prepareNormalState "first" 40 | addTestMigrationWithDeps state1 [] 41 | state2 <- prepareStateWith state1 "second" 42 | addTestMigrationWithDeps state2 ["first"] 43 | state3 <- prepareStateWith state2 "third" 44 | addTestMigrationWithDeps state3 ["first"] 45 | state4' <- prepareStateWith state3 "fourth" 46 | let state4 = state4' { _appLinearMigrations = True } 47 | Right mig <- addTestMigration state4 48 | return $ ["second", "third"] ~=? mDeps mig 49 | 50 | doesNotAddDependencyWhenLinearMigrationsAreDisabled :: IO Test 51 | doesNotAddDependencyWhenLinearMigrationsAreDisabled = do 52 | state1 <- prepareNormalState "first" 53 | _ <- addTestMigration state1 54 | state2 <- prepareStateWith state1 "second" 55 | Right mig <- addTestMigration state2 56 | satisfies "Dependencies should be empty" (mDeps mig) null 57 | 58 | addTestMigration :: AppState -> IO (Either String Migration) 59 | addTestMigration state = do 60 | let store = _appStore state 61 | [migrationId] = _appRequiredArgs state 62 | runReaderT (newCommand $ _appStoreData state) state 63 | loadMigration store migrationId 64 | 65 | addTestMigrationWithDeps :: AppState -> [Text] -> IO () 66 | addTestMigrationWithDeps state deps = do 67 | let store = _appStore state 68 | let [migrationId] = _appRequiredArgs state 69 | saveMigration store (newMigration migrationId) { mDeps = deps } 70 | 71 | prepareState :: Text -> IO AppState 72 | prepareState m = do 73 | store <- inMemoryStore 74 | Right storeData <- loadMigrations store 75 | return AppState { 76 | _appOptions = CommandOptions Nothing False True 77 | , _appBackend = undefined -- Not used here 78 | , _appCommand = undefined -- Not used by newCommand 79 | , _appRequiredArgs = [m] 80 | , _appOptionalArgs = [] 81 | , _appStore = store 82 | , _appStoreData = storeData 83 | , _appLinearMigrations = True 84 | , _appTimestampFilenames = False 85 | } 86 | 87 | prepareStateWith :: AppState -> Text -> IO AppState 88 | prepareStateWith state m = do 89 | Right storeData <- loadMigrations $ _appStore state 90 | return state { _appRequiredArgs = [m], _appStoreData = storeData } 91 | 92 | prepareNormalState :: Text -> IO AppState 93 | prepareNormalState m = do 94 | state <- prepareState m 95 | return $ state { _appLinearMigrations = False } 96 | -------------------------------------------------------------------------------- /test/DependencyTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module DependencyTest 3 | ( tests 4 | ) 5 | where 6 | 7 | import Data.Text ( Text ) 8 | 9 | import Test.HUnit 10 | import Data.Graph.Inductive.Graph ( Graph(..) ) 11 | 12 | import Database.Schema.Migrations.Dependencies 13 | import Common 14 | 15 | tests :: [Test] 16 | tests = depGraphTests ++ dependencyTests 17 | 18 | type DepGraphTestCase = ([TestDependable], Either String (DependencyGraph TestDependable)) 19 | 20 | depGraphTestCases :: [DepGraphTestCase] 21 | depGraphTestCases = [ ( [] 22 | , Right $ DG [] [] empty 23 | ) 24 | , ( [first, second] 25 | , Right $ DG [(first,1),(second,2)] 26 | [("first",1),("second",2)] (mkGraph [(1, "first"), (2, "second")] 27 | [(2, 1, "first -> second")]) 28 | ) 29 | , ( [cycleFirst, cycleSecond] 30 | , Left "Invalid dependency graph; cycle detected") 31 | ] 32 | where 33 | first = TD "first" [] 34 | second = TD "second" ["first"] 35 | cycleFirst = TD "first" ["second"] 36 | cycleSecond = TD "second" ["first"] 37 | 38 | depGraphTests :: [Test] 39 | depGraphTests = map mkDepGraphTest depGraphTestCases 40 | 41 | mkDepGraphTest :: DepGraphTestCase -> Test 42 | mkDepGraphTest (input, expected) = expected ~=? mkDepGraph input 43 | 44 | data Direction = Forward | Reverse deriving (Show) 45 | type DependencyTestCase = ([TestDependable], Text, Direction, [Text]) 46 | 47 | dependencyTestCases :: [DependencyTestCase] 48 | dependencyTestCases = [ ([TD "first" []], "first", Forward, []) 49 | , ([TD "first" []], "first", Reverse, []) 50 | 51 | , ([TD "first" ["second"], TD "second" []], "first", Forward, ["second"]) 52 | , ([TD "first" ["second"], TD "second" []], "second", Reverse, ["first"]) 53 | , ([TD "first" ["second"], TD "second" ["third"], TD "third" []], "first", Forward, ["third", "second"]) 54 | , ([TD "first" ["second"], TD "second" ["third"], TD "third" [], TD "fourth" ["third"]] 55 | , "first", Forward, ["third", "second"]) 56 | , ([TD "first" [], TD "second" ["first"]] 57 | , "first", Reverse, ["second"]) 58 | , ([TD "first" [], TD "second" ["first"], TD "third" ["second"]] 59 | , "first", Reverse, ["third", "second"]) 60 | , ([TD "first" [], TD "second" ["first"], TD "third" ["second"], TD "fourth" ["second"]] 61 | , "first", Reverse, ["fourth", "third", "second"]) 62 | , ([ TD "first" ["second"], TD "second" ["third"], TD "third" ["fourth"] 63 | , TD "second" ["fifth"], TD "fifth" ["third"], TD "fourth" []] 64 | , "fourth", Reverse, ["first", "second", "fifth", "third"]) 65 | , ([ TD "first" ["second"], TD "second" ["third", "fifth"], TD "third" ["fourth"] 66 | , TD "fifth" ["third"], TD "fourth" []] 67 | , "first", Forward, ["fourth", "third", "fifth", "second"]) 68 | ] 69 | 70 | fromRight :: Either a b -> b 71 | fromRight (Left _) = error "Got a Left value" 72 | fromRight (Right v) = v 73 | 74 | mkDependencyTest :: DependencyTestCase -> Test 75 | mkDependencyTest testCase@(deps, a, dir, expected) = 76 | let f = case dir of 77 | Forward -> dependencies 78 | Reverse -> reverseDependencies 79 | in (show testCase) ~: expected ~=? f (fromRight $ mkDepGraph deps) a 80 | 81 | dependencyTests :: [Test] 82 | dependencyTests = map mkDependencyTest dependencyTestCases 83 | -------------------------------------------------------------------------------- /src/Database/Schema/Migrations.hs: -------------------------------------------------------------------------------- 1 | -- |This module provides a high-level interface for the rest of this 2 | -- library. 3 | module Database.Schema.Migrations 4 | ( createNewMigration 5 | , ensureBootstrappedBackend 6 | , migrationsToApply 7 | , migrationsToRevert 8 | , missingMigrations 9 | ) 10 | where 11 | 12 | import Data.Text ( Text ) 13 | import qualified Data.Set as Set 14 | import Data.Maybe ( catMaybes ) 15 | 16 | import Database.Schema.Migrations.Dependencies 17 | ( dependencies 18 | , reverseDependencies 19 | ) 20 | import qualified Database.Schema.Migrations.Backend as B 21 | import qualified Database.Schema.Migrations.Store as S 22 | import Database.Schema.Migrations.Migration 23 | ( Migration(..) 24 | ) 25 | 26 | -- |Given a 'B.Backend' and a 'S.MigrationMap', query the backend and 27 | -- return a list of migration names which are available in the 28 | -- 'S.MigrationMap' but which are not installed in the 'B.Backend'. 29 | missingMigrations :: B.Backend -> S.StoreData -> IO [Text] 30 | missingMigrations backend storeData = do 31 | let storeMigrationNames = map mId $ S.storeMigrations storeData 32 | backendMigrations <- B.getMigrations backend 33 | 34 | return $ Set.toList $ Set.difference 35 | (Set.fromList storeMigrationNames) 36 | (Set.fromList backendMigrations) 37 | 38 | -- |Create a new migration and store it in the 'S.MigrationStore'. 39 | createNewMigration :: S.MigrationStore -- ^ The 'S.MigrationStore' in which to create a new migration 40 | -> Migration -- ^ The new migration 41 | -> IO (Either String Migration) 42 | createNewMigration store newM = do 43 | available <- S.getMigrations store 44 | case mId newM `elem` available of 45 | True -> do 46 | fullPath <- S.fullMigrationName store (mId newM) 47 | return $ Left $ "Migration " ++ (show fullPath) ++ " already exists" 48 | False -> do 49 | S.saveMigration store newM 50 | return $ Right newM 51 | 52 | -- |Given a 'B.Backend', ensure that the backend is ready for use by 53 | -- bootstrapping it. This entails installing the appropriate database 54 | -- elements to track installed migrations. If the backend is already 55 | -- bootstrapped, this has no effect. 56 | ensureBootstrappedBackend :: B.Backend -> IO () 57 | ensureBootstrappedBackend backend = do 58 | bsStatus <- B.isBootstrapped backend 59 | case bsStatus of 60 | True -> return () 61 | False -> B.getBootstrapMigration backend >>= B.applyMigration backend 62 | 63 | -- |Given a migration mapping computed from a MigrationStore, a 64 | -- backend, and a migration to apply, return a list of migrations to 65 | -- apply, in order. 66 | migrationsToApply :: S.StoreData -> B.Backend 67 | -> Migration -> IO [Migration] 68 | migrationsToApply storeData backend migration = do 69 | let graph = S.storeDataGraph storeData 70 | 71 | allMissing <- missingMigrations backend storeData 72 | 73 | let deps = (dependencies graph $ mId migration) ++ [mId migration] 74 | namesToInstall = [ e | e <- deps, e `elem` allMissing ] 75 | loadedMigrations = catMaybes $ map (S.storeLookup storeData) namesToInstall 76 | 77 | return loadedMigrations 78 | 79 | -- |Given a migration mapping computed from a MigrationStore, a 80 | -- backend, and a migration to revert, return a list of migrations to 81 | -- revert, in order. 82 | migrationsToRevert :: S.StoreData -> B.Backend 83 | -> Migration -> IO [Migration] 84 | migrationsToRevert storeData backend migration = do 85 | let graph = S.storeDataGraph storeData 86 | 87 | allInstalled <- B.getMigrations backend 88 | 89 | let rDeps = (reverseDependencies graph $ mId migration) ++ [mId migration] 90 | namesToRevert = [ e | e <- rDeps, e `elem` allInstalled ] 91 | loadedMigrations = catMaybes $ map (S.storeLookup storeData) namesToRevert 92 | 93 | return loadedMigrations 94 | -------------------------------------------------------------------------------- /test/StoreTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module StoreTest 3 | ( tests 4 | ) 5 | where 6 | 7 | import Test.HUnit 8 | import qualified Data.Map as Map 9 | 10 | import Database.Schema.Migrations.Migration 11 | import Database.Schema.Migrations.Store 12 | 13 | tests :: [Test] 14 | tests = validateSingleMigrationTests 15 | ++ validateMigrationMapTests 16 | 17 | type ValidateSingleTestCase = ( MigrationMap 18 | , Migration 19 | , [MapValidationError] 20 | ) 21 | 22 | type ValidateMigrationMapTestCase = ( MigrationMap 23 | , [MapValidationError] 24 | ) 25 | 26 | emptyMap :: MigrationMap 27 | emptyMap = Map.fromList [] 28 | 29 | partialMap :: MigrationMap 30 | partialMap = Map.fromList [ ("one", undefined) 31 | , ("three", undefined) 32 | ] 33 | 34 | fullMap :: MigrationMap 35 | fullMap = Map.fromList [ ("one", undefined) 36 | , ("two", undefined) 37 | , ("three", undefined) 38 | ] 39 | 40 | withDeps :: Migration 41 | withDeps = Migration { mTimestamp = undefined 42 | , mId = "with_deps" 43 | , mDesc = Just "with dependencies" 44 | , mApply = "" 45 | , mRevert = Nothing 46 | , mDeps = ["one", "two", "three"] 47 | } 48 | 49 | noDeps :: Migration 50 | noDeps = Migration { mTimestamp = undefined 51 | , mId = "no_deps" 52 | , mDesc = Just "no dependencies" 53 | , mApply = "" 54 | , mRevert = Nothing 55 | , mDeps = [] 56 | } 57 | 58 | validateSingleTestCases :: [ValidateSingleTestCase] 59 | validateSingleTestCases = [ (emptyMap, withDeps, [ DependencyReferenceError (mId withDeps) "one" 60 | , DependencyReferenceError (mId withDeps) "two" 61 | , DependencyReferenceError (mId withDeps) "three" 62 | ] 63 | ) 64 | , (emptyMap, noDeps, []) 65 | , (partialMap, withDeps, [DependencyReferenceError (mId withDeps) "two"]) 66 | , (fullMap, withDeps, []) 67 | , (fullMap, noDeps, []) 68 | ] 69 | 70 | validateSingleMigrationTests :: [Test] 71 | validateSingleMigrationTests = 72 | map mkValidateSingleTest validateSingleTestCases 73 | where 74 | mkValidateSingleTest (mmap, m, errs) = 75 | errs ~=? validateSingleMigration mmap m 76 | 77 | m1 :: Migration 78 | m1 = noDeps { mId = "m1" 79 | , mDeps = [] } 80 | 81 | m2 :: Migration 82 | m2 = noDeps { mId = "m2" 83 | , mDeps = ["m1"] } 84 | 85 | m3 :: Migration 86 | m3 = noDeps { mId = "m3" 87 | , mDeps = ["nonexistent"] } 88 | 89 | m4 :: Migration 90 | m4 = noDeps { mId = "m4" 91 | , mDeps = ["one", "two"] } 92 | 93 | map1 :: MigrationMap 94 | map1 = Map.fromList [ ("m1", m1) 95 | , ("m2", m2) 96 | ] 97 | 98 | map2 :: MigrationMap 99 | map2 = Map.fromList [ ("m3", m3) 100 | ] 101 | 102 | map3 :: MigrationMap 103 | map3 = Map.fromList [ ("m4", m4) 104 | ] 105 | 106 | validateMapTestCases :: [ValidateMigrationMapTestCase] 107 | validateMapTestCases = [ (emptyMap, []) 108 | , (map1, []) 109 | , (map2, [DependencyReferenceError (mId m3) "nonexistent"]) 110 | , (map3, [ DependencyReferenceError (mId m4) "one" 111 | , DependencyReferenceError (mId m4) "two"]) 112 | ] 113 | 114 | validateMigrationMapTests :: [Test] 115 | validateMigrationMapTests = 116 | map mkValidateMapTest validateMapTestCases 117 | where 118 | mkValidateMapTest (mmap, errs) = 119 | errs ~=? validateMigrationMap mmap 120 | -------------------------------------------------------------------------------- /src/Database/Schema/Migrations/Dependencies.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeSynonymInstances, OverloadedStrings #-} 2 | -- |This module types and functions for representing a dependency 3 | -- graph of arbitrary objects and functions for querying such graphs 4 | -- to get dependency and reverse dependency information. 5 | module Database.Schema.Migrations.Dependencies 6 | ( Dependable(..) 7 | , DependencyGraph(..) 8 | , mkDepGraph 9 | , dependencies 10 | , reverseDependencies 11 | ) 12 | where 13 | 14 | import Data.Text ( Text ) 15 | import Data.Maybe ( fromJust ) 16 | import Data.Monoid ( (<>) ) 17 | import Data.Graph.Inductive.Graph ( Graph(..), nodes, edges, Node, suc, pre, lab ) 18 | import Data.Graph.Inductive.PatriciaTree ( Gr ) 19 | 20 | import Database.Schema.Migrations.CycleDetection ( hasCycle ) 21 | 22 | -- |'Dependable' objects supply a representation of their identifiers, 23 | -- and a list of other objects upon which they depend. 24 | class (Eq a, Ord a) => Dependable a where 25 | -- |The identifiers of the objects on which @a@ depends. 26 | depsOf :: a -> [Text] 27 | -- |The identifier of a 'Dependable' object. 28 | depId :: a -> Text 29 | 30 | -- |A 'DependencyGraph' represents a collection of objects together 31 | -- with a graph of their dependency relationships. This is intended 32 | -- to be used with instances of 'Dependable'. 33 | data DependencyGraph a = DG { depGraphObjectMap :: [(a, Int)] 34 | -- ^ A mapping of 'Dependable' objects to 35 | -- their graph vertex indices. 36 | , depGraphNameMap :: [(Text, Int)] 37 | -- ^ A mapping of 'Dependable' object 38 | -- identifiers to their graph vertex 39 | -- indices. 40 | , depGraph :: Gr Text Text 41 | -- ^ A directed 'Gr' (graph) of the 42 | -- 'Dependable' objects' dependency 43 | -- relationships, with 'Text' vertex and 44 | -- edge labels. 45 | } 46 | 47 | instance (Eq a) => Eq (DependencyGraph a) where 48 | g1 == g2 = ((nodes $ depGraph g1) == (nodes $ depGraph g2) && 49 | (edges $ depGraph g1) == (edges $ depGraph g2)) 50 | 51 | instance (Show a) => Show (DependencyGraph a) where 52 | show g = "(" ++ (show $ nodes $ depGraph g) ++ ", " ++ (show $ edges $ depGraph g) ++ ")" 53 | 54 | -- XXX: provide details about detected cycles 55 | -- |Build a dependency graph from a list of 'Dependable's. Return the 56 | -- graph on success or return an error message if the graph cannot be 57 | -- constructed (e.g., if the graph contains a cycle). 58 | mkDepGraph :: (Dependable a) => [a] -> Either String (DependencyGraph a) 59 | mkDepGraph objects = if hasCycle theGraph 60 | then Left "Invalid dependency graph; cycle detected" 61 | else Right $ DG { depGraphObjectMap = ids 62 | , depGraphNameMap = names 63 | , depGraph = theGraph 64 | } 65 | where 66 | theGraph = mkGraph n e 67 | n = [ (fromJust $ lookup o ids, depId o) | o <- objects ] 68 | e = [ ( fromJust $ lookup o ids 69 | , fromJust $ lookup d ids 70 | , depId o <> " -> " <> depId d) | o <- objects, d <- depsOf' o ] 71 | depsOf' o = map (\i -> fromJust $ lookup i objMap) $ depsOf o 72 | 73 | objMap = map (\o -> (depId o, o)) objects 74 | ids = zip objects [1..] 75 | names = map (\(o,i) -> (depId o, i)) ids 76 | 77 | type NextNodesFunc = Gr Text Text -> Node -> [Node] 78 | 79 | cleanLDups :: (Eq a) => [a] -> [a] 80 | cleanLDups [] = [] 81 | cleanLDups [e] = [e] 82 | cleanLDups (e:es) = if e `elem` es then (cleanLDups es) else (e:cleanLDups es) 83 | 84 | -- |Given a dependency graph and an ID, return the IDs of objects that 85 | -- the object depends on. IDs are returned with least direct 86 | -- dependencies first (i.e., the apply order). 87 | dependencies :: (Dependable d) => DependencyGraph d -> Text -> [Text] 88 | dependencies g m = reverse $ cleanLDups $ dependenciesWith suc g m 89 | 90 | -- |Given a dependency graph and an ID, return the IDs of objects that 91 | -- depend on it. IDs are returned with least direct reverse 92 | -- dependencies first (i.e., the revert order). 93 | reverseDependencies :: (Dependable d) => DependencyGraph d -> Text -> [Text] 94 | reverseDependencies g m = reverse $ cleanLDups $ dependenciesWith pre g m 95 | 96 | dependenciesWith :: (Dependable d) => NextNodesFunc -> DependencyGraph d -> Text -> [Text] 97 | dependenciesWith nextNodes dg@(DG _ nMap theGraph) name = 98 | let lookupId = fromJust $ lookup name nMap 99 | depNodes = nextNodes theGraph lookupId 100 | recurse theNodes = map (dependenciesWith nextNodes dg) theNodes 101 | getLabel node = fromJust $ lab theGraph node 102 | labels = map getLabel depNodes 103 | in labels ++ (concat $ recurse labels) 104 | -------------------------------------------------------------------------------- /src/Moo/CommandInterface.hs: -------------------------------------------------------------------------------- 1 | -- |This module defines the MOO command interface, the commnad line options 2 | -- parser, and helpers to manipulate the Command data structure. 3 | module Moo.CommandInterface 4 | ( commands 5 | , commandOptionUsage 6 | , findCommand 7 | , getCommandArgs 8 | , usageString 9 | ) where 10 | 11 | import Data.Maybe 12 | import Moo.CommandHandlers 13 | import Moo.Core 14 | import System.Console.GetOpt 15 | 16 | -- |The available commands; used to dispatch from the command line and 17 | -- used to generate usage output. 18 | -- |The available commands; used to dispatch from the command line and 19 | -- used to generate usage output. 20 | commands :: [Command] 21 | commands = [ Command "new" [migrationName] 22 | [] 23 | ["no-ask", configFile] 24 | "Create a new empty migration" 25 | newCommand 26 | 27 | , Command "apply" [migrationName] 28 | [] 29 | [testOption, configFile] 30 | "Apply the specified migration and its \ 31 | \dependencies" 32 | applyCommand 33 | 34 | , Command "revert" [migrationName] 35 | [] 36 | [testOption, configFile] 37 | "Revert the specified migration and those \ 38 | \that depend on it" 39 | revertCommand 40 | 41 | , Command "test" [migrationName] 42 | [] 43 | [configFile] 44 | "Test the specified migration by applying \ 45 | \and reverting it in a transaction, then \ 46 | \roll back" 47 | testCommand 48 | 49 | , Command "upgrade" [] 50 | [] 51 | [testOption, configFile] 52 | "Install all migrations that have not yet \ 53 | \been installed" 54 | 55 | upgradeCommand 56 | 57 | , Command "upgrade-list" [] 58 | [] 59 | [] 60 | "Show the list of migrations not yet \ 61 | \installed" 62 | upgradeListCommand 63 | 64 | , Command "reinstall" [migrationName] 65 | [] 66 | [testOption, configFile] 67 | "Reinstall a migration by reverting, then \ 68 | \reapplying it" 69 | reinstallCommand 70 | 71 | , Command "list" [] 72 | [] 73 | [configFile] 74 | "List migrations already installed in the backend" 75 | listCommand 76 | ] 77 | where migrationName = "migrationName" 78 | testOption = "test" 79 | configFile = "config-file" 80 | 81 | 82 | findCommand :: String -> Maybe Command 83 | findCommand name = listToMaybe [ c | c <- commands, _cName c == name ] 84 | 85 | commandOptions :: [ OptDescr (CommandOptions -> IO CommandOptions) ] 86 | commandOptions = [ optionConfigFile 87 | , optionTest 88 | , optionNoAsk 89 | ] 90 | 91 | optionConfigFile :: OptDescr (CommandOptions -> IO CommandOptions) 92 | optionConfigFile = Option "c" ["config-file"] 93 | (ReqArg (\arg opt -> 94 | return opt { _configFilePath = Just arg }) "FILE") 95 | "Specify location of configuration file" 96 | 97 | optionTest :: OptDescr (CommandOptions -> IO CommandOptions) 98 | optionTest = Option "t" ["test"] 99 | (NoArg (\opt -> return opt { _test = True })) 100 | "Perform the action then rollback when finished" 101 | 102 | optionNoAsk :: OptDescr (CommandOptions -> IO CommandOptions) 103 | optionNoAsk = Option "n" ["no-ask"] 104 | (NoArg (\opt -> return opt { _noAsk = True })) 105 | "Do not interactively ask any questions, just do it" 106 | 107 | getCommandArgs :: [String] -> IO ( CommandOptions, [String] ) 108 | getCommandArgs args = do 109 | let (actions, required, _) = getOpt RequireOrder commandOptions args 110 | opts <- foldl (>>=) defaultOptions actions 111 | return ( opts, required ) 112 | 113 | defaultOptions :: IO CommandOptions 114 | defaultOptions = return $ CommandOptions Nothing False False 115 | 116 | commandOptionUsage :: String 117 | commandOptionUsage = usageInfo "Options:" commandOptions 118 | 119 | usageString :: Command -> String 120 | usageString command = 121 | unwords (_cName command:optionalArgs ++ options ++ requiredArgs) 122 | where 123 | requiredArgs = map (\s -> "<" ++ s ++ ">") $ _cRequired command 124 | optionalArgs = map (\s -> "[" ++ s ++ "]") $ _cOptional command 125 | options = map (\s -> "["++ "--" ++ s ++ "]") optionStrings 126 | optionStrings = _cAllowedOptions command 127 | -------------------------------------------------------------------------------- /test/FilesystemParseTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module FilesystemParseTest 3 | ( tests 4 | ) 5 | where 6 | 7 | import Test.HUnit 8 | import Data.Time.Clock ( UTCTime ) 9 | import System.FilePath ( () ) 10 | import Data.String.Conversions ( cs ) 11 | 12 | import Common 13 | 14 | import Database.Schema.Migrations.Migration 15 | import Database.Schema.Migrations.Filesystem 16 | ( FilesystemStoreSettings(..) 17 | , migrationFromFile 18 | ) 19 | 20 | tests :: IO [Test] 21 | tests = migrationParsingTests 22 | 23 | -- filename, result 24 | type MigrationParsingTestCase = (FilePath, Either String Migration) 25 | 26 | tsStr :: String 27 | tsStr = "2009-04-15 10:02:06 UTC" 28 | 29 | ts :: UTCTime 30 | ts = read tsStr 31 | 32 | valid_full :: Migration 33 | valid_full = Migration { 34 | mTimestamp = Just ts 35 | , mId = "valid_full" 36 | , mDesc = Just "A valid full migration." 37 | , mDeps = ["another_migration"] 38 | , mApply = "CREATE TABLE test ( a int );" 39 | , mRevert = Just "DROP TABLE test;" 40 | } 41 | 42 | valid_full_comments :: Migration 43 | valid_full_comments = Migration { 44 | mTimestamp = Just ts 45 | , mId = "valid_full" 46 | , mDesc = Just "A valid full migration." 47 | , mDeps = ["another_migration"] 48 | , mApply = "\n-- Comment on a line\nCREATE TABLE test (\n a int -- comment inline\n);\n" 49 | , mRevert = Just "DROP TABLE test;" 50 | } 51 | 52 | valid_full_colon :: Migration 53 | valid_full_colon = Migration { 54 | mTimestamp = Just ts 55 | , mId = "valid_full" 56 | , mDesc = Just "A valid full migration." 57 | , mDeps = ["another_migration"] 58 | , mApply = "\n-- Comment on a line with a colon:\nCREATE TABLE test (\n a int\n);\n" 59 | , mRevert = Just "DROP TABLE test;" 60 | } 61 | 62 | testStorePath :: FilePath 63 | testStorePath = testFile $ "migration_parsing" 64 | 65 | fp :: FilePath -> FilePath 66 | fp = (testStorePath ) 67 | 68 | migrationParsingTestCases :: [MigrationParsingTestCase] 69 | migrationParsingTestCases = [ ("valid_full", Right valid_full) 70 | , ("valid_with_comments" 71 | , Right (valid_full { mId = "valid_with_comments" })) 72 | , ("valid_with_comments2" 73 | , Right (valid_full_comments { mId = "valid_with_comments2" })) 74 | , ("valid_with_colon" 75 | , Right (valid_full_colon { mId = "valid_with_colon" })) 76 | , ("valid_with_multiline_deps" 77 | , Right (valid_full { mId = "valid_with_multiline_deps" 78 | , mDeps = ["one", "two", "three"] } )) 79 | , ("valid_no_depends" 80 | , Right (valid_full { mId = "valid_no_depends", mDeps = [] })) 81 | , ("valid_no_desc" 82 | , Right (valid_full { mId = "valid_no_desc", mDesc = Nothing })) 83 | , ("valid_no_revert" 84 | , Right (valid_full { mId = "valid_no_revert", mRevert = Nothing })) 85 | , ("valid_no_timestamp" 86 | , Right (valid_full { mId = "valid_no_timestamp", mTimestamp = Nothing })) 87 | , ("invalid_missing_required_fields" 88 | , Left $ "Could not parse migration " ++ 89 | (fp "invalid_missing_required_fields") ++ 90 | ":Error in " ++ 91 | (show $ fp "invalid_missing_required_fields") ++ 92 | ": missing required field(s): " ++ 93 | "[\"Depends\"]") 94 | , ("invalid_field_name" 95 | , Left $ "Could not parse migration " ++ 96 | (fp "invalid_field_name") ++ 97 | ":Error in " ++ 98 | (show $ fp "invalid_field_name") ++ 99 | ": unrecognized field found") 100 | , ("invalid_syntax" 101 | , Left $ "Could not parse migration " ++ 102 | (fp "invalid_syntax") ++ 103 | ":InvalidYaml (Just (YamlParseException {yamlProblem = \"could not find expected ':'\", yamlContext = \"while scanning a simple key\", yamlProblemMark = YamlMark {yamlIndex = 130, yamlLine = 6, yamlColumn = 0}}))") 104 | , ("invalid_timestamp" 105 | , Left $ "Could not parse migration " ++ 106 | (fp "invalid_timestamp") ++ 107 | ":Error in " ++ 108 | (show $ fp "invalid_timestamp") ++ 109 | ": unrecognized field found") 110 | ] 111 | 112 | mkParsingTest :: MigrationParsingTestCase -> IO Test 113 | mkParsingTest (fname, expected) = do 114 | let store = FSStore { storePath = testStorePath } 115 | actual <- migrationFromFile store (cs fname) 116 | return $ test $ expected ~=? actual 117 | 118 | migrationParsingTests :: IO [Test] 119 | migrationParsingTests = 120 | traverse mkParsingTest migrationParsingTestCases 121 | -------------------------------------------------------------------------------- /dbmigrations.cabal: -------------------------------------------------------------------------------- 1 | Name: dbmigrations 2 | Version: 2.1.0 3 | Synopsis: An implementation of relational database "migrations" 4 | Description: A library and program for the creation, 5 | management, and installation of schema updates 6 | (called /migrations/) for a relational database. In 7 | particular, this package lets the migration author 8 | express explicit dependencies between migrations 9 | and the management tool automatically installs or 10 | reverts migrations accordingly, using transactions 11 | for safety. 12 | 13 | This package is written to support a number of 14 | different databases. For packages that support 15 | specific databases using this library, see packages 16 | named "dbmigrations-BACKEND". Each package 17 | provides an executable "moo-BACKEND" for managing 18 | migrations. Usage information for the "moo-" 19 | executables can be found in "MOO.TXT" in this 20 | package. 21 | 22 | This package also includes a conformance test suite 23 | to ensure that backend implementations respect the 24 | library's required semantics. 25 | 26 | Category: Database 27 | Author: Jonathan Daugherty 28 | Maintainer: Jonathan Daugherty 29 | Build-Type: Simple 30 | License: BSD3 31 | License-File: LICENSE 32 | Cabal-Version: >= 1.10 33 | 34 | Data-Files: 35 | README.md 36 | MOO.TXT 37 | test/example_store/root 38 | test/example_store/update1 39 | test/example_store/update2 40 | test/config_loading/cfg1.cfg 41 | test/config_loading/cfg_ts.cfg 42 | test/config_loading/invalid.cfg 43 | test/config_loading/missing.cfg 44 | test/config_loading/moo.cfg 45 | test/migration_parsing/invalid_field_name.txt 46 | test/migration_parsing/invalid_missing_required_fields.txt 47 | test/migration_parsing/invalid_syntax.txt 48 | test/migration_parsing/invalid_timestamp.txt 49 | test/migration_parsing/valid_full.txt 50 | test/migration_parsing/valid_no_depends.txt 51 | test/migration_parsing/valid_no_desc.txt 52 | test/migration_parsing/valid_no_revert.txt 53 | test/migration_parsing/valid_no_timestamp.txt 54 | test/migration_parsing/valid_with_colon.txt 55 | test/migration_parsing/valid_with_comments.txt 56 | test/migration_parsing/valid_with_comments2.txt 57 | test/migration_parsing/valid_with_multiline_deps.txt 58 | 59 | Source-Repository head 60 | type: git 61 | location: git://github.com/jtdaugherty/dbmigrations.git 62 | 63 | Library 64 | default-language: Haskell2010 65 | if impl(ghc >= 6.12.0) 66 | ghc-options: -Wall -fwarn-tabs -funbox-strict-fields 67 | -fno-warn-unused-do-bind 68 | else 69 | ghc-options: -Wall -fwarn-tabs -funbox-strict-fields 70 | 71 | Build-Depends: 72 | base >= 4 && < 5, 73 | HDBC >= 2.2.1, 74 | time >= 1.4, 75 | random >= 1.0, 76 | containers >= 0.2, 77 | mtl >= 2.1, 78 | filepath >= 1.1, 79 | directory >= 1.0, 80 | fgl >= 5.4, 81 | template-haskell, 82 | yaml, 83 | bytestring >= 0.9, 84 | string-conversions >= 0.4, 85 | text >= 0.11, 86 | configurator >= 0.2, 87 | split >= 0.2.2, 88 | HUnit >= 1.2, 89 | aeson, 90 | unordered-containers 91 | 92 | Hs-Source-Dirs: src 93 | Exposed-Modules: 94 | Database.Schema.Migrations 95 | Database.Schema.Migrations.Backend 96 | Database.Schema.Migrations.Backend.HDBC 97 | Database.Schema.Migrations.CycleDetection 98 | Database.Schema.Migrations.Dependencies 99 | Database.Schema.Migrations.Filesystem 100 | Database.Schema.Migrations.Filesystem.Serialize 101 | Database.Schema.Migrations.Migration 102 | Database.Schema.Migrations.Store 103 | Database.Schema.Migrations.Test.BackendTest 104 | Moo.CommandHandlers 105 | Moo.CommandInterface 106 | Moo.CommandUtils 107 | Moo.Core 108 | Moo.Main 109 | 110 | test-suite dbmigrations-tests 111 | default-language: Haskell2010 112 | type: exitcode-stdio-1.0 113 | Build-Depends: 114 | base >= 4 && < 5, 115 | dbmigrations, 116 | time >= 1.4, 117 | containers >= 0.2, 118 | mtl >= 2.1, 119 | filepath >= 1.1, 120 | directory >= 1.0, 121 | fgl >= 5.4, 122 | template-haskell, 123 | yaml, 124 | bytestring >= 0.9, 125 | string-conversions >= 0.4, 126 | MissingH, 127 | HDBC >= 2.2.1, 128 | HUnit >= 1.2, 129 | process >= 1.1, 130 | configurator >= 0.2, 131 | text >= 0.11, 132 | split >= 0.2.2 133 | 134 | other-modules: 135 | Common 136 | CommonTH 137 | CycleDetectionTest 138 | DependencyTest 139 | FilesystemParseTest 140 | FilesystemSerializeTest 141 | FilesystemTest 142 | MigrationsTest 143 | StoreTest 144 | InMemoryStore 145 | LinearMigrationsTest 146 | ConfigurationTest 147 | 148 | if impl(ghc >= 6.12.0) 149 | ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields 150 | -fno-warn-unused-do-bind -Wwarn 151 | else 152 | ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields 153 | 154 | Hs-Source-Dirs: test 155 | Main-is: Main.hs 156 | 157 | Executable moo 158 | default-language: Haskell2010 159 | Build-Depends: 160 | base >= 4 && < 5, 161 | configurator >= 0.2, 162 | dbmigrations 163 | 164 | if impl(ghc >= 6.12.0) 165 | ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields 166 | -fno-warn-unused-do-bind 167 | else 168 | ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields 169 | 170 | Hs-Source-Dirs: programs 171 | Main-is: Moo.hs 172 | -------------------------------------------------------------------------------- /src/Database/Schema/Migrations/Filesystem.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, DeriveGeneric, LambdaCase, ScopedTypeVariables, OverloadedStrings #-} 2 | -- |This module provides a type for interacting with a 3 | -- filesystem-backed 'MigrationStore'. 4 | module Database.Schema.Migrations.Filesystem 5 | ( FilesystemStoreSettings(..) 6 | , migrationFromFile 7 | , migrationFromPath 8 | , filesystemStore 9 | ) 10 | where 11 | 12 | import Prelude 13 | 14 | import System.Directory ( getDirectoryContents, doesFileExist ) 15 | import System.FilePath ( (), takeExtension, dropExtension, takeBaseName ) 16 | import Data.Text ( Text ) 17 | import qualified Data.Text as T 18 | import qualified Data.ByteString.Char8 as BSC 19 | import Data.String.Conversions ( cs, (<>) ) 20 | 21 | import Data.Typeable ( Typeable ) 22 | import Data.Time.Clock ( UTCTime ) 23 | import Data.Time ( defaultTimeLocale, formatTime, parseTimeM ) 24 | import qualified Data.Map as Map 25 | 26 | import Control.Monad ( filterM ) 27 | import Control.Exception ( Exception(..), throw, catch ) 28 | 29 | import Data.Aeson 30 | import Data.Aeson.Types (typeMismatch) 31 | import qualified Data.Yaml as Yaml 32 | import GHC.Generics (Generic) 33 | 34 | import Database.Schema.Migrations.Migration (Migration(..)) 35 | import Database.Schema.Migrations.Filesystem.Serialize 36 | import Database.Schema.Migrations.Store 37 | 38 | data FilesystemStoreSettings = FSStore { storePath :: FilePath } 39 | 40 | data FilesystemStoreError = FilesystemStoreError String 41 | deriving (Show, Typeable) 42 | 43 | instance Exception FilesystemStoreError 44 | 45 | throwFS :: String -> a 46 | throwFS = throw . FilesystemStoreError 47 | 48 | filenameExtension :: String 49 | filenameExtension = ".yml" 50 | 51 | filenameExtensionTxt :: String 52 | filenameExtensionTxt = ".txt" 53 | 54 | filesystemStore :: FilesystemStoreSettings -> MigrationStore 55 | filesystemStore s = 56 | MigrationStore { fullMigrationName = fmap addNewMigrationExtension . fsFullMigrationName s 57 | 58 | , loadMigration = \theId -> migrationFromFile s theId 59 | 60 | , getMigrations = do 61 | contents <- getDirectoryContents $ storePath s 62 | let migrationFilenames = [ f | f <- contents, isMigrationFilename f ] 63 | fullPaths = [ (f, storePath s f) | f <- migrationFilenames ] 64 | existing <- filterM (\(_, full) -> doesFileExist full) fullPaths 65 | return [ cs $ dropExtension short | (short, _) <- existing ] 66 | 67 | , saveMigration = \m -> do 68 | filename <- fsFullMigrationName s $ mId m 69 | BSC.writeFile (cs $ addNewMigrationExtension filename) $ serializeMigration m 70 | } 71 | 72 | addNewMigrationExtension :: FilePath -> FilePath 73 | addNewMigrationExtension path = path <> filenameExtension 74 | 75 | addMigrationExtension :: FilePath -> String -> FilePath 76 | addMigrationExtension path ext = path <> ext 77 | 78 | -- |Build path to migrations without extension. 79 | fsFullMigrationName :: FilesystemStoreSettings -> Text -> IO FilePath 80 | fsFullMigrationName s name = return $ storePath s cs name 81 | 82 | isMigrationFilename :: String -> Bool 83 | isMigrationFilename path = (cs $ takeExtension path) `elem` [filenameExtension, filenameExtensionTxt] 84 | 85 | -- |Given a store and migration name, read and parse the associated 86 | -- migration and return the migration if successful. Otherwise return 87 | -- a parsing error message. 88 | migrationFromFile :: FilesystemStoreSettings -> Text -> IO (Either String Migration) 89 | migrationFromFile store name = 90 | fsFullMigrationName store (cs name) >>= migrationFromPath 91 | 92 | -- |Given a filesystem path, read and parse the file as a migration 93 | -- return the 'Migration' if successful. Otherwise return a parsing 94 | -- error message. 95 | migrationFromPath :: FilePath -> IO (Either String Migration) 96 | migrationFromPath path = do 97 | let name = cs $ takeBaseName path 98 | (Right <$> process name) `catch` (\(FilesystemStoreError s) -> return $ Left $ "Could not parse migration " ++ path ++ ":" ++ s) 99 | 100 | where 101 | readMigrationFile = do 102 | ymlExists <- doesFileExist (addNewMigrationExtension path) 103 | if ymlExists 104 | then Yaml.decodeFileThrow (addNewMigrationExtension path) `catch` (\(e::Yaml.ParseException) -> throwFS $ show e) 105 | else Yaml.decodeFileThrow (addMigrationExtension path filenameExtensionTxt) `catch` (\(e::Yaml.ParseException) -> throwFS $ show e) 106 | 107 | process name = migrationYamlToMigration name <$> readMigrationFile 108 | 109 | -- | TODO: re-use this for the generation side too 110 | data MigrationYaml = MigrationYaml 111 | { myCreated :: Maybe UTCTimeYaml 112 | , myDescription :: Maybe Text 113 | , myApply :: Text 114 | , myRevert :: Maybe Text 115 | , myDepends :: DependsYaml 116 | } 117 | deriving Generic 118 | 119 | instance FromJSON MigrationYaml where 120 | parseJSON = genericParseJSON jsonOptions 121 | 122 | instance ToJSON MigrationYaml where 123 | toJSON = genericToJSON jsonOptions 124 | toEncoding = genericToEncoding jsonOptions 125 | 126 | jsonOptions :: Options 127 | jsonOptions = defaultOptions 128 | { fieldLabelModifier = drop 2 -- remove "my" prefix 129 | , omitNothingFields = True 130 | , rejectUnknownFields = True 131 | } 132 | 133 | migrationYamlToMigration :: Text -> MigrationYaml -> Migration 134 | migrationYamlToMigration theId my = Migration 135 | { mTimestamp = unUTCTimeYaml <$> myCreated my 136 | , mId = theId 137 | , mDesc = myDescription my 138 | , mApply = myApply my 139 | , mRevert = myRevert my 140 | , mDeps = unDependsYaml $ myDepends my 141 | } 142 | 143 | newtype UTCTimeYaml = UTCTimeYaml 144 | { unUTCTimeYaml :: UTCTime 145 | } 146 | 147 | instance FromJSON UTCTimeYaml where 148 | parseJSON = withText "UTCTime" 149 | $ maybe (fail "Unable to parse UTCTime") (pure . UTCTimeYaml) 150 | . parseTimeM True defaultTimeLocale utcTimeYamlFormat 151 | . cs 152 | 153 | instance ToJSON UTCTimeYaml where 154 | toJSON = toJSON . formatTime defaultTimeLocale utcTimeYamlFormat . unUTCTimeYaml 155 | toEncoding = toEncoding . formatTime defaultTimeLocale utcTimeYamlFormat . unUTCTimeYaml 156 | 157 | -- Keeps things as the old Show/Read-based format, e.g "2009-04-15 10:02:06 UTC" 158 | utcTimeYamlFormat :: String 159 | utcTimeYamlFormat = "%F %T UTC" 160 | 161 | newtype DependsYaml = DependsYaml 162 | { unDependsYaml :: [Text] 163 | } 164 | 165 | instance FromJSON DependsYaml where 166 | parseJSON = \case 167 | Null -> pure $ DependsYaml [] 168 | String t -> pure $ DependsYaml $ T.words t 169 | x -> typeMismatch "Null or whitespace-separated String" x 170 | 171 | instance ToJSON DependsYaml where 172 | toJSON (DependsYaml ts) = case ts of 173 | [] -> toJSON Null 174 | _ -> toJSON $ T.unwords ts 175 | toEncoding (DependsYaml ts) = case ts of 176 | [] -> toEncoding Null 177 | _ -> toEncoding $ T.unwords ts 178 | -------------------------------------------------------------------------------- /src/Database/Schema/Migrations/Store.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | -- |This module provides an abstraction for a /migration store/, a 3 | -- facility in which 'Migration's can be stored and from which they 4 | -- can be loaded. This module also provides functions for taking 5 | -- 'Migration's from a store and converting them into the appropriate 6 | -- intermediate types for use with the rest of this library. 7 | module Database.Schema.Migrations.Store 8 | ( MigrationStore(..) 9 | , MapValidationError(..) 10 | , StoreData(..) 11 | , MigrationMap 12 | 13 | -- * High-level Store API 14 | , loadMigrations 15 | , storeMigrations 16 | , storeLookup 17 | 18 | -- * Miscellaneous Functions 19 | , depGraphFromMapping 20 | , validateMigrationMap 21 | , validateSingleMigration 22 | , leafMigrations 23 | ) 24 | where 25 | 26 | import Data.Text ( Text ) 27 | import Data.Maybe ( isJust ) 28 | import Control.Monad ( mzero ) 29 | import Control.Applicative ( (<$>) ) 30 | import qualified Data.Map as Map 31 | import Data.Graph.Inductive.Graph ( labNodes, indeg ) 32 | 33 | import Database.Schema.Migrations.Migration 34 | ( Migration(..) 35 | ) 36 | import Database.Schema.Migrations.Dependencies 37 | ( DependencyGraph(..) 38 | , mkDepGraph 39 | , depsOf 40 | ) 41 | 42 | -- |A mapping from migration name to 'Migration'. This is exported 43 | -- for testing purposes, but you'll want to interface with this 44 | -- through the encapsulating 'StoreData' type. 45 | type MigrationMap = Map.Map Text Migration 46 | 47 | data StoreData = StoreData { storeDataMapping :: MigrationMap 48 | , storeDataGraph :: DependencyGraph Migration 49 | } 50 | 51 | -- |The type of migration storage facilities. A MigrationStore is a 52 | -- facility in which new migrations can be created, and from which 53 | -- existing migrations can be loaded. 54 | data MigrationStore = 55 | MigrationStore { loadMigration :: Text -> IO (Either String Migration) 56 | -- ^ Load a migration from the store. 57 | 58 | , saveMigration :: Migration -> IO () 59 | -- ^ Save a migration to the store. 60 | 61 | , getMigrations :: IO [Text] 62 | -- ^ Return a list of all available migrations' 63 | -- names. 64 | 65 | , fullMigrationName :: Text -> IO FilePath 66 | -- ^ Return the full representation of a given 67 | -- migration name; mostly for filesystem stores, 68 | -- where the full representation includes the store 69 | -- path. 70 | } 71 | 72 | -- |A type for types of validation errors for migration maps. 73 | data MapValidationError = DependencyReferenceError Text Text 74 | -- ^ A migration claims a dependency on a 75 | -- migration that does not exist. 76 | | DependencyGraphError String 77 | -- ^ An error was encountered when 78 | -- constructing the dependency graph for 79 | -- this store. 80 | | InvalidMigration String 81 | -- ^ The specified migration is invalid. 82 | deriving (Eq) 83 | 84 | instance Show MapValidationError where 85 | show (DependencyReferenceError from to) = 86 | "Migration " ++ (show from) ++ " references nonexistent dependency " ++ show to 87 | show (DependencyGraphError msg) = 88 | "There was an error constructing the dependency graph: " ++ msg 89 | show (InvalidMigration msg) = 90 | "There was an error loading a migration: " ++ msg 91 | 92 | -- |A convenience function for extracting the list of 'Migration's 93 | -- extant in the specified 'StoreData'. 94 | storeMigrations :: StoreData -> [Migration] 95 | storeMigrations storeData = 96 | Map.elems $ storeDataMapping storeData 97 | 98 | -- |A convenience function for looking up a 'Migration' by name in the 99 | -- specified 'StoreData'. 100 | storeLookup :: StoreData -> Text -> Maybe Migration 101 | storeLookup storeData migrationName = 102 | Map.lookup migrationName $ storeDataMapping storeData 103 | 104 | -- |Load migrations from the specified 'MigrationStore', validate the 105 | -- loaded migrations, and return errors or a 'MigrationMap' on 106 | -- success. Generally speaking, this will be the first thing you 107 | -- should call once you have constructed a 'MigrationStore'. 108 | loadMigrations :: MigrationStore -> IO (Either [MapValidationError] StoreData) 109 | loadMigrations store = do 110 | migrations <- getMigrations store 111 | loadedWithErrors <- mapM (\name -> loadMigration store name) migrations 112 | 113 | let mMap = Map.fromList $ [ (mId e, e) | e <- loaded ] 114 | validationErrors = validateMigrationMap mMap 115 | (loaded, loadErrors) = sortResults loadedWithErrors ([], []) 116 | allErrors = validationErrors ++ (InvalidMigration <$> loadErrors) 117 | 118 | sortResults [] v = v 119 | sortResults (Left e:rest) (ms, es) = sortResults rest (ms, e:es) 120 | sortResults (Right m:rest) (ms, es) = sortResults rest (m:ms, es) 121 | 122 | case null allErrors of 123 | False -> return $ Left allErrors 124 | True -> do 125 | -- Construct a dependency graph and, if that succeeds, return 126 | -- StoreData. 127 | case depGraphFromMapping mMap of 128 | Left e -> return $ Left [DependencyGraphError e] 129 | Right gr -> return $ Right StoreData { storeDataMapping = mMap 130 | , storeDataGraph = gr 131 | } 132 | 133 | -- |Validate a migration map. Returns zero or more validation errors. 134 | validateMigrationMap :: MigrationMap -> [MapValidationError] 135 | validateMigrationMap mMap = do 136 | validateSingleMigration mMap =<< snd <$> Map.toList mMap 137 | 138 | -- |Validate a single migration. Looks up the migration's 139 | -- dependencies in the specified 'MigrationMap' and returns a 140 | -- 'MapValidationError' for each one that does not exist in the map. 141 | validateSingleMigration :: MigrationMap -> Migration -> [MapValidationError] 142 | validateSingleMigration mMap m = do 143 | depId <- depsOf m 144 | if isJust $ Map.lookup depId mMap then 145 | mzero else 146 | return $ DependencyReferenceError (mId m) depId 147 | 148 | -- |Create a 'DependencyGraph' from a 'MigrationMap'; returns Left if 149 | -- the dependency graph cannot be constructed (e.g., due to a 150 | -- dependency cycle) or Right on success. Generally speaking, you 151 | -- won't want to use this directly; use 'loadMigrations' instead. 152 | depGraphFromMapping :: MigrationMap -> Either String (DependencyGraph Migration) 153 | depGraphFromMapping mapping = mkDepGraph $ Map.elems mapping 154 | 155 | -- |Finds migrations that no other migration depends on (effectively finds all 156 | -- vertices with in-degree equal to zero). 157 | leafMigrations :: StoreData -> [Text] 158 | leafMigrations s = [l | (n, l) <- labNodes g, indeg g n == 0] 159 | where g = depGraph $ storeDataGraph s 160 | -------------------------------------------------------------------------------- /src/Moo/CommandHandlers.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | module Moo.CommandHandlers where 5 | 6 | import Data.String.Conversions (cs, (<>)) 7 | 8 | import Moo.Core 9 | import Moo.CommandUtils 10 | import Control.Monad ( when, forM_ ) 11 | import Data.Maybe ( isJust ) 12 | import Control.Monad.Reader ( asks ) 13 | import System.Exit ( exitWith, ExitCode(..), exitSuccess ) 14 | import qualified Data.Time.Clock as Clock 15 | import Control.Monad.Trans ( liftIO ) 16 | 17 | import Database.Schema.Migrations.Store hiding (getMigrations) 18 | import Database.Schema.Migrations 19 | import Database.Schema.Migrations.Migration 20 | import Database.Schema.Migrations.Backend 21 | 22 | newCommand :: CommandHandler 23 | newCommand storeData = do 24 | required <- asks _appRequiredArgs 25 | store <- asks _appStore 26 | linear <- asks _appLinearMigrations 27 | timestamp <- asks _appTimestampFilenames 28 | timeString <- (<>"_") <$> liftIO getCurrentTimestamp 29 | 30 | let [migrationId] = if timestamp 31 | then fmap (timeString<>) required 32 | else required 33 | noAsk <- _noAsk <$> asks _appOptions 34 | 35 | liftIO $ do 36 | fullPath <- fullMigrationName store migrationId 37 | when (isJust $ storeLookup storeData migrationId) $ 38 | do 39 | putStrLn $ "Migration " <> (show fullPath) ++ " already exists" 40 | exitWith (ExitFailure 1) 41 | 42 | -- Default behavior: ask for dependencies if linear mode is disabled 43 | deps <- if linear then (return $ leafMigrations storeData) else 44 | if noAsk then (return []) else 45 | do 46 | putStrLn . cs $ "Selecting dependencies for new \ 47 | \migration: " <> migrationId 48 | interactiveAskDeps storeData 49 | 50 | result <- if noAsk then (return True) else 51 | (confirmCreation migrationId deps) 52 | 53 | case result of 54 | True -> do 55 | now <- Clock.getCurrentTime 56 | status <- createNewMigration store $ (newMigration migrationId) { mDeps = deps 57 | , mTimestamp = Just now 58 | } 59 | case status of 60 | Left e -> putStrLn e >> (exitWith (ExitFailure 1)) 61 | Right _ -> putStrLn $ "Migration created successfully: " ++ 62 | show fullPath 63 | False -> do 64 | putStrLn "Migration creation cancelled." 65 | 66 | upgradeCommand :: CommandHandler 67 | upgradeCommand storeData = do 68 | isTesting <- _test <$> asks _appOptions 69 | withBackend $ \backend -> do 70 | ensureBootstrappedBackend backend >> commitBackend backend 71 | migrationNames <- missingMigrations backend storeData 72 | when (null migrationNames) $ do 73 | putStrLn "Database is up to date." 74 | exitSuccess 75 | forM_ migrationNames $ \migrationName -> do 76 | m <- lookupMigration storeData migrationName 77 | apply m storeData backend False 78 | case isTesting of 79 | True -> do 80 | rollbackBackend backend 81 | putStrLn "Upgrade test successful." 82 | False -> do 83 | commitBackend backend 84 | putStrLn "Database successfully upgraded." 85 | 86 | upgradeListCommand :: CommandHandler 87 | upgradeListCommand storeData = do 88 | withBackend $ \backend -> do 89 | ensureBootstrappedBackend backend >> commitBackend backend 90 | migrationNames <- missingMigrations backend storeData 91 | when (null migrationNames) $ do 92 | putStrLn "Database is up to date." 93 | exitSuccess 94 | putStrLn "Migrations to install:" 95 | forM_ migrationNames (putStrLn . cs . (" " <>)) 96 | 97 | reinstallCommand :: CommandHandler 98 | reinstallCommand storeData = do 99 | isTesting <- _test <$> asks _appOptions 100 | required <- asks _appRequiredArgs 101 | let [migrationId] = required 102 | 103 | withBackend $ \backend -> do 104 | ensureBootstrappedBackend backend >> commitBackend backend 105 | m <- lookupMigration storeData migrationId 106 | 107 | _ <- revert m storeData backend 108 | _ <- apply m storeData backend True 109 | 110 | case isTesting of 111 | False -> do 112 | commitBackend backend 113 | putStrLn "Migration successfully reinstalled." 114 | True -> do 115 | rollbackBackend backend 116 | putStrLn "Reinstall test successful." 117 | 118 | listCommand :: CommandHandler 119 | listCommand _ = do 120 | withBackend $ \backend -> do 121 | ensureBootstrappedBackend backend >> commitBackend backend 122 | ms <- getMigrations backend 123 | forM_ ms $ \m -> 124 | when (not $ m == rootMigrationName) $ putStrLn . cs $ m 125 | 126 | applyCommand :: CommandHandler 127 | applyCommand storeData = do 128 | isTesting <- _test <$> asks _appOptions 129 | required <- asks _appRequiredArgs 130 | let [migrationId] = required 131 | 132 | withBackend $ \backend -> do 133 | ensureBootstrappedBackend backend >> commitBackend backend 134 | m <- lookupMigration storeData migrationId 135 | _ <- apply m storeData backend True 136 | case isTesting of 137 | False -> do 138 | commitBackend backend 139 | putStrLn "Successfully applied migrations." 140 | True -> do 141 | rollbackBackend backend 142 | putStrLn "Migration installation test successful." 143 | 144 | revertCommand :: CommandHandler 145 | revertCommand storeData = do 146 | isTesting <- _test <$> asks _appOptions 147 | required <- asks _appRequiredArgs 148 | let [migrationId] = required 149 | 150 | withBackend $ \backend -> do 151 | ensureBootstrappedBackend backend >> commitBackend backend 152 | m <- lookupMigration storeData migrationId 153 | _ <- revert m storeData backend 154 | 155 | case isTesting of 156 | False -> do 157 | commitBackend backend 158 | putStrLn "Successfully reverted migrations." 159 | True -> do 160 | rollbackBackend backend 161 | putStrLn "Migration uninstallation test successful." 162 | 163 | testCommand :: CommandHandler 164 | testCommand storeData = do 165 | required <- asks _appRequiredArgs 166 | let [migrationId] = required 167 | 168 | withBackend $ \backend -> do 169 | ensureBootstrappedBackend backend >> commitBackend backend 170 | m <- lookupMigration storeData migrationId 171 | migrationNames <- missingMigrations backend storeData 172 | -- If the migration is already installed, remove it as part of 173 | -- the test 174 | when (not $ migrationId `elem` migrationNames) $ 175 | do _ <- revert m storeData backend 176 | return () 177 | applied <- apply m storeData backend True 178 | forM_ (reverse applied) $ \migration -> do 179 | revert migration storeData backend 180 | rollbackBackend backend 181 | putStrLn "Successfully tested migrations." 182 | -------------------------------------------------------------------------------- /src/Database/Schema/Migrations/Test/BackendTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | -- | A test that is not executed as part of this package's test suite but rather 4 | -- acts as a conformance test suit for database specific backend 5 | -- implementations. All backend specific executable packages are expected to 6 | -- have a test suite that runs this test. 7 | module Database.Schema.Migrations.Test.BackendTest 8 | ( BackendConnection (..) 9 | , tests 10 | ) where 11 | 12 | import Data.ByteString ( ByteString ) 13 | 14 | import Control.Monad ( forM_ ) 15 | import Test.HUnit 16 | 17 | import Database.Schema.Migrations.Migration ( Migration(..), newMigration ) 18 | import Database.Schema.Migrations.Backend ( Backend(..) ) 19 | 20 | -- | A typeclass for database connections that needs to implemented for each 21 | -- specific database type to use this test. 22 | class BackendConnection c where 23 | 24 | -- | Whether this backend supports transactional DDL; if it doesn't, 25 | -- we'll skip any tests that rely on that behavior. 26 | supportsTransactionalDDL :: c -> Bool 27 | 28 | -- | Commits the current transaction. 29 | commit :: c -> IO () 30 | 31 | -- | Executes an IO action inside a transaction. 32 | withTransaction :: c -> (c -> IO a) -> IO a 33 | 34 | -- | Retrieves a list of all tables in the current database/scheme. 35 | getTables :: c -> IO [ByteString] 36 | 37 | catchAll :: c -> (IO a -> IO a -> IO a) 38 | 39 | -- | Returns a backend instance. 40 | makeBackend :: c -> Backend 41 | 42 | testSuite :: BackendConnection bc => Bool -> [bc -> IO ()] 43 | testSuite transactDDL = 44 | [ isBootstrappedFalseTest 45 | , bootstrapTest 46 | , isBootstrappedTrueTest 47 | , if transactDDL then applyMigrationFailure else (const $ return ()) 48 | , applyMigrationSuccess 49 | , revertMigrationFailure 50 | , revertMigrationNothing 51 | , revertMigrationJust 52 | ] 53 | 54 | tests :: BackendConnection bc => bc -> IO () 55 | tests conn = do 56 | let acts = testSuite $ supportsTransactionalDDL conn 57 | forM_ acts $ \act -> do 58 | commit conn 59 | act conn 60 | 61 | bootstrapTest :: BackendConnection bc => bc -> IO () 62 | bootstrapTest conn = do 63 | let backend = makeBackend conn 64 | bs <- getBootstrapMigration backend 65 | applyMigration backend bs 66 | assertEqual "installed_migrations table exists" ["installed_migrations"] =<< getTables conn 67 | assertEqual "successfully bootstrapped" [mId bs] =<< getMigrations backend 68 | 69 | isBootstrappedTrueTest :: BackendConnection bc => bc -> IO () 70 | isBootstrappedTrueTest conn = do 71 | result <- isBootstrapped $ makeBackend conn 72 | assertBool "Bootstrapped check" result 73 | 74 | isBootstrappedFalseTest :: BackendConnection bc => bc -> IO () 75 | isBootstrappedFalseTest conn = do 76 | result <- isBootstrapped $ makeBackend conn 77 | assertBool "Bootstrapped check" $ not result 78 | 79 | ignoreSqlExceptions :: BackendConnection bc => bc -> IO a -> IO (Maybe a) 80 | ignoreSqlExceptions conn act = 81 | (catchAll conn) 82 | (act >>= return . Just) 83 | (return Nothing) 84 | 85 | applyMigrationSuccess :: BackendConnection bc => bc -> IO () 86 | applyMigrationSuccess conn = do 87 | let backend = makeBackend conn 88 | 89 | let m1 = (newMigration "validMigration") { mApply = "CREATE TABLE valid1 (a int)" } 90 | 91 | -- Apply the migrations, ignore exceptions 92 | withTransaction conn $ \conn' -> applyMigration (makeBackend conn') m1 93 | 94 | -- Check that none of the migrations were installed 95 | assertEqual "Installed migrations" ["root", "validMigration"] =<< getMigrations backend 96 | assertEqual "Installed tables" ["installed_migrations", "valid1"] =<< getTables conn 97 | 98 | -- |Does a failure to apply a migration imply a transaction rollback? 99 | applyMigrationFailure :: BackendConnection bc => bc -> IO () 100 | applyMigrationFailure conn = do 101 | let backend = makeBackend conn 102 | 103 | let m1 = (newMigration "second") { mApply = "CREATE TABLE validButTemporary (a int)" } 104 | m2 = (newMigration "third") { mApply = "INVALID SQL" } 105 | 106 | -- Apply the migrations, ignore exceptions 107 | _ <- ignoreSqlExceptions conn $ withTransaction conn $ \conn' -> do 108 | let backend' = makeBackend conn' 109 | applyMigration backend' m1 110 | applyMigration backend' m2 111 | 112 | -- Check that none of the migrations were installed 113 | assertEqual "Installed migrations" ["root"] =<< getMigrations backend 114 | assertEqual "Installed tables" ["installed_migrations"] =<< getTables conn 115 | 116 | revertMigrationFailure :: BackendConnection bc => bc -> IO () 117 | revertMigrationFailure conn = do 118 | let backend = makeBackend conn 119 | 120 | let m1 = (newMigration "second") { mApply = "CREATE TABLE validRMF (a int)" 121 | , mRevert = Just "DROP TABLE validRMF"} 122 | m2 = (newMigration "third") { mApply = "alter table validRMF add column b int" 123 | , mRevert = Just "INVALID REVERT SQL"} 124 | 125 | applyMigration backend m1 126 | applyMigration backend m2 127 | 128 | installedBeforeRevert <- getMigrations backend 129 | 130 | commitBackend backend 131 | 132 | -- Revert the migrations, ignore exceptions; the revert will fail, 133 | -- but withTransaction will roll back. 134 | _ <- ignoreSqlExceptions conn $ withTransaction conn $ \conn' -> do 135 | let backend' = makeBackend conn' 136 | revertMigration backend' m2 137 | revertMigration backend' m1 138 | 139 | -- Check that none of the migrations were reverted 140 | assertEqual "successfully roll back failed revert" installedBeforeRevert 141 | =<< getMigrations backend 142 | 143 | revertMigrationNothing :: BackendConnection bc => bc -> IO () 144 | revertMigrationNothing conn = do 145 | let backend = makeBackend conn 146 | 147 | let m1 = (newMigration "second") { mApply = "create table revert_nothing (a int)" 148 | , mRevert = Nothing } 149 | 150 | applyMigration backend m1 151 | 152 | installedAfterApply <- getMigrations backend 153 | assertBool "Check that the migration was applied" $ "second" `elem` installedAfterApply 154 | 155 | -- Revert the migration, which should do nothing EXCEPT remove it 156 | -- from the installed list 157 | revertMigration backend m1 158 | 159 | installed <- getMigrations backend 160 | assertBool "Check that the migration was reverted" $ not $ "second" `elem` installed 161 | 162 | revertMigrationJust :: BackendConnection bc => bc -> IO () 163 | revertMigrationJust conn = do 164 | let name = "revertable" 165 | backend = makeBackend conn 166 | 167 | let m1 = (newMigration name) { mApply = "CREATE TABLE the_test_table (a int)" 168 | , mRevert = Just "DROP TABLE the_test_table" } 169 | 170 | applyMigration backend m1 171 | 172 | installedAfterApply <- getMigrations backend 173 | assertBool "Check that the migration was applied" $ name `elem` installedAfterApply 174 | 175 | -- Revert the migration, which should do nothing EXCEPT remove it 176 | -- from the installed list 177 | revertMigration backend m1 178 | 179 | installed <- getMigrations backend 180 | assertBool "Check that the migration was reverted" $ not $ name `elem` installed 181 | -------------------------------------------------------------------------------- /src/Moo/Core.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | module Moo.Core 3 | ( AppT 4 | , CommandHandler 5 | , CommandOptions (..) 6 | , Command (..) 7 | , AppState (..) 8 | , Configuration (..) 9 | , makeParameters 10 | , ExecutableParameters (..) 11 | , envDatabaseName 12 | , envLinearMigrations 13 | , envStoreName 14 | , loadConfiguration) where 15 | 16 | import Data.Text ( Text ) 17 | 18 | import Control.Monad.Reader (ReaderT) 19 | import qualified Data.Configurator as C 20 | import Data.Configurator.Types (Config, Configured) 21 | import qualified Data.Text as T 22 | import Data.Char (toLower) 23 | import System.Environment (getEnvironment) 24 | import Data.Maybe (fromMaybe) 25 | 26 | import Database.Schema.Migrations.Store (MigrationStore, StoreData) 27 | import Database.Schema.Migrations.Backend 28 | 29 | -- |The monad in which the application runs. 30 | type AppT a = ReaderT AppState IO a 31 | 32 | -- |The type of actions that are invoked to handle specific commands 33 | type CommandHandler = StoreData -> AppT () 34 | 35 | -- |Application state which can be accessed by any command handler. 36 | data AppState = AppState { _appOptions :: CommandOptions 37 | , _appCommand :: Command 38 | , _appRequiredArgs :: [Text] 39 | , _appOptionalArgs :: [Text] 40 | , _appBackend :: Backend 41 | , _appStore :: MigrationStore 42 | , _appStoreData :: StoreData 43 | , _appLinearMigrations :: Bool 44 | , _appTimestampFilenames :: Bool 45 | } 46 | 47 | type ShellEnvironment = [(String, String)] 48 | 49 | -- |Intermediate type used during config loading. 50 | data LoadConfig = LoadConfig 51 | { _lcConnectionString :: Maybe String 52 | , _lcMigrationStorePath :: Maybe FilePath 53 | , _lcLinearMigrations :: Maybe Bool 54 | , _lcTimestampFilenames :: Maybe Bool 55 | } deriving Show 56 | 57 | -- |Loading the configuration from a file or having it specified via environment 58 | -- |variables results in a value of type Configuration. 59 | data Configuration = Configuration 60 | { _connectionString :: String 61 | , _migrationStorePath :: FilePath 62 | , _linearMigrations :: Bool 63 | , _timestampFilenames :: Bool 64 | } deriving Show 65 | 66 | -- |A value of type ExecutableParameters is what a moo executable (moo-postgresql, 67 | -- |moo-mysql, etc.) pass to the core package when they want to execute a 68 | -- |command. 69 | data ExecutableParameters = ExecutableParameters 70 | { _parametersBackend :: Backend 71 | , _parametersMigrationStorePath :: FilePath 72 | , _parametersLinearMigrations :: Bool 73 | , _parametersTimestampFilenames :: Bool 74 | } deriving Show 75 | 76 | defConfigFile :: String 77 | defConfigFile = "moo.cfg" 78 | 79 | newLoadConfig :: LoadConfig 80 | newLoadConfig = LoadConfig Nothing Nothing Nothing Nothing 81 | 82 | validateLoadConfig :: LoadConfig -> Either String Configuration 83 | validateLoadConfig (LoadConfig Nothing _ _ _) = 84 | Left "Invalid configuration: connection string not specified" 85 | validateLoadConfig (LoadConfig _ Nothing _ _) = 86 | Left "Invalid configuration: migration store path not specified" 87 | validateLoadConfig (LoadConfig (Just cs) (Just msp) lm ts) = 88 | Right $ Configuration cs msp (fromMaybe False lm) (fromMaybe False ts) 89 | 90 | -- |Setters for fields of 'LoadConfig'. 91 | lcConnectionString, lcMigrationStorePath 92 | :: LoadConfig -> Maybe String -> LoadConfig 93 | lcConnectionString c v = c { _lcConnectionString = v } 94 | lcMigrationStorePath c v = c { _lcMigrationStorePath = v } 95 | 96 | lcLinearMigrations :: LoadConfig -> Maybe Bool -> LoadConfig 97 | lcLinearMigrations c v = c { _lcLinearMigrations = v } 98 | 99 | lcTimestampFilenames :: LoadConfig -> Maybe Bool -> LoadConfig 100 | lcTimestampFilenames c v = c { _lcTimestampFilenames = v } 101 | 102 | 103 | -- | @f .= v@ invokes f only if v is 'Just' 104 | (.=) :: (Monad m) => (a -> Maybe b -> a) -> m (Maybe b) -> m (a -> a) 105 | (.=) f v' = do 106 | v <- v' 107 | return $ case v of 108 | Just _ -> flip f v 109 | _ -> id 110 | 111 | -- |It's just @flip '<*>'@ 112 | (&) :: (Applicative m) => m a -> m (a -> b) -> m b 113 | (&) = flip (<*>) 114 | 115 | infixr 3 .= 116 | infixl 2 & 117 | 118 | applyEnvironment :: ShellEnvironment -> LoadConfig -> IO LoadConfig 119 | applyEnvironment env lc = 120 | return lc & lcConnectionString .= f envDatabaseName 121 | & lcMigrationStorePath .= f envStoreName 122 | & lcLinearMigrations .= readFlag <$> f envLinearMigrations 123 | & lcTimestampFilenames .= readFlag <$> f envTimestampFilenames 124 | where f n = return $ lookup n env 125 | 126 | applyConfigFile :: Config -> LoadConfig -> IO LoadConfig 127 | applyConfigFile cfg lc = 128 | return lc & lcConnectionString .= f envDatabaseName 129 | & lcMigrationStorePath .= f envStoreName 130 | & lcLinearMigrations .= f envLinearMigrations 131 | & lcTimestampFilenames .= f envTimestampFilenames 132 | where 133 | f :: Configured a => String -> IO (Maybe a) 134 | f = C.lookup cfg . T.pack 135 | 136 | -- |Loads config file (falling back to default one if not specified) and then 137 | -- overrides configuration with an environment. 138 | loadConfiguration :: Maybe FilePath -> IO (Either String Configuration) 139 | loadConfiguration pth = do 140 | file <- maybe (C.load [C.Optional defConfigFile]) 141 | (\p -> C.load [C.Required p]) pth 142 | env <- getEnvironment 143 | cfg <- applyConfigFile file newLoadConfig >>= applyEnvironment env 144 | 145 | return $ validateLoadConfig cfg 146 | 147 | makeParameters :: Configuration -> Backend -> ExecutableParameters 148 | makeParameters conf backend = 149 | ExecutableParameters 150 | { _parametersBackend = backend 151 | , _parametersMigrationStorePath = _migrationStorePath conf 152 | , _parametersLinearMigrations = _linearMigrations conf 153 | , _parametersTimestampFilenames = _timestampFilenames conf 154 | } 155 | 156 | -- |Converts @Just "on"@ and @Just "true"@ (case insensitive) to @True@, 157 | -- anything else to @False@. 158 | readFlag :: Maybe String -> Maybe Bool 159 | readFlag Nothing = Nothing 160 | readFlag (Just v) = go $ map toLower v 161 | where 162 | go "on" = Just True 163 | go "true" = Just True 164 | go "off" = Just False 165 | go "false" = Just False 166 | go _ = Nothing 167 | 168 | -- |CommandOptions are those options that can be specified at the command 169 | -- prompt to modify the behavior of a command. 170 | data CommandOptions = CommandOptions { _configFilePath :: Maybe String 171 | , _test :: Bool 172 | , _noAsk :: Bool 173 | } 174 | 175 | -- |A command has a name, a number of required arguments' labels, a 176 | -- number of optional arguments' labels, and an action to invoke. 177 | data Command = Command { _cName :: String 178 | , _cRequired :: [String] 179 | , _cOptional :: [String] 180 | , _cAllowedOptions :: [String] 181 | , _cDescription :: String 182 | , _cHandler :: CommandHandler 183 | } 184 | 185 | envDatabaseName :: String 186 | envDatabaseName = "DBM_DATABASE" 187 | 188 | envStoreName :: String 189 | envStoreName = "DBM_MIGRATION_STORE" 190 | 191 | envLinearMigrations :: String 192 | envLinearMigrations = "DBM_LINEAR_MIGRATIONS" 193 | 194 | envTimestampFilenames :: String 195 | envTimestampFilenames = "DBM_TIMESTAMP_FILENAMES" 196 | 197 | -------------------------------------------------------------------------------- /src/StoreManager.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Applicative ( (<$>) ) 4 | import Control.Monad.State 5 | import qualified Data.Map as Map 6 | import System.Environment 7 | ( getArgs 8 | , getProgName 9 | , getEnvironment 10 | ) 11 | import System.Exit 12 | ( exitFailure 13 | ) 14 | import System.IO 15 | ( Handle 16 | , hClose 17 | , openTempFile 18 | , hPutStr 19 | ) 20 | import System.Directory 21 | ( getTemporaryDirectory 22 | ) 23 | import System.Process 24 | import System.Posix.Files 25 | ( removeLink 26 | ) 27 | 28 | import Data.Maybe 29 | ( fromJust 30 | ) 31 | 32 | import Graphics.Vty 33 | import Graphics.Vty.Widgets.All 34 | import Database.Schema.Migrations.Filesystem 35 | import Database.Schema.Migrations.Migration 36 | ( Migration(..) 37 | ) 38 | import Database.Schema.Migrations.Store 39 | 40 | -- XXX Generalize over all MigrationStore instances 41 | data AppState = AppState { appStoreData :: StoreData 42 | , appStore :: FilesystemStore 43 | , appMigrationList :: SimpleList 44 | , appVty :: Vty 45 | } 46 | 47 | type AppM = StateT AppState IO 48 | 49 | titleAttr :: Attr 50 | titleAttr = def_attr 51 | `with_back_color` blue 52 | `with_fore_color` bright_white 53 | 54 | bodyAttr :: Attr 55 | bodyAttr = def_attr 56 | `with_back_color` black 57 | `with_fore_color` bright_white 58 | 59 | fieldAttr :: Attr 60 | fieldAttr = def_attr 61 | `with_back_color` black 62 | `with_fore_color` bright_green 63 | 64 | selAttr :: Attr 65 | selAttr = def_attr 66 | `with_back_color` yellow 67 | `with_fore_color` black 68 | 69 | scrollListUp :: AppState -> AppState 70 | scrollListUp appst = 71 | appst { appMigrationList = scrollUp $ appMigrationList appst } 72 | 73 | scrollListDown :: AppState -> AppState 74 | scrollListDown appst = 75 | appst { appMigrationList = scrollDown $ appMigrationList appst } 76 | 77 | eventloop :: (Widget a) => AppM a -> (Event -> AppM Bool) -> AppM () 78 | eventloop uiBuilder handle = do 79 | w <- uiBuilder 80 | vty <- gets appVty 81 | evt <- liftIO $ do 82 | (img, _) <- mkImage vty w 83 | update vty $ pic_for_image img 84 | next_event vty 85 | next <- handle evt 86 | if next then 87 | eventloop uiBuilder handle else 88 | return () 89 | 90 | continue :: AppM Bool 91 | continue = return True 92 | 93 | stop :: AppM Bool 94 | stop = return False 95 | 96 | handleEvent :: Event -> AppM Bool 97 | handleEvent (EvKey KUp []) = modify scrollListUp >> continue 98 | handleEvent (EvKey KDown []) = modify scrollListDown >> continue 99 | handleEvent (EvKey (KASCII 'q') []) = stop 100 | handleEvent (EvKey (KASCII 'e') []) = editCurrentMigration >> continue 101 | handleEvent (EvResize w h) = do 102 | let wSize = appropriateListWindow $ DisplayRegion (toEnum w) (toEnum h) 103 | modify (\appst -> appst { appMigrationList = (appMigrationList appst) { scrollWindowSize = wSize }}) 104 | continue 105 | handleEvent _ = continue 106 | 107 | withTempFile :: (MonadIO m) => (Handle -> FilePath -> m a) -> m a 108 | withTempFile act = do 109 | (tempFilePath, newFile) <- liftIO $ createTempFile 110 | result <- act newFile tempFilePath 111 | liftIO $ cleanup newFile tempFilePath 112 | return result 113 | where 114 | createTempFile = do 115 | tempDir <- getTemporaryDirectory 116 | openTempFile tempDir "migration.txt" 117 | 118 | cleanup handle tempFilePath = do 119 | (hClose handle) `catch` (\_ -> return ()) 120 | removeLink tempFilePath 121 | 122 | editCurrentMigration :: AppM () 123 | editCurrentMigration = do 124 | -- Get the current migration 125 | m <- gets getSelectedMigration 126 | store <- gets appStore 127 | migrationPath <- fullMigrationName store $ mId m 128 | vty <- gets appVty 129 | 130 | withTempFile $ \tempHandle tempPath -> 131 | liftIO $ do 132 | -- Copy the migration to a temporary file 133 | readFile migrationPath >>= hPutStr tempHandle 134 | hClose tempHandle 135 | 136 | shutdown vty 137 | 138 | currentEnv <- getEnvironment 139 | let editor = maybe "vi" id $ lookup "EDITOR" currentEnv 140 | spawnEditor = do 141 | -- Invoke an editor to edit the temporary file 142 | (_, _, _, pHandle) <- createProcess $ shell $ editor ++ " " ++ tempPath 143 | waitForProcess pHandle 144 | 145 | -- Once the editor closes, validate the temporary file 146 | validateResult <- migrationFromPath tempPath 147 | case validateResult of 148 | Left e -> do 149 | putStrLn $ "Error in edited migration: " ++ e 150 | putStrLn $ "Try again? (y/n) " 151 | c <- getChar 152 | if c == 'y' then spawnEditor else return False 153 | Right _ -> return True 154 | 155 | proceed <- spawnEditor 156 | 157 | -- Replace the original migration with the contents of the 158 | -- temporary file 159 | when (proceed) (readFile tempPath >>= writeFile migrationPath) 160 | 161 | -- Reinitialize application state 162 | put =<< (liftIO $ mkState store) 163 | 164 | getSelectedMigration :: AppState -> Migration 165 | getSelectedMigration appst = fromJust $ Map.lookup (fst $ getSelected list) mMap 166 | where mMap = storeDataMapping $ appStoreData appst 167 | list = appMigrationList appst 168 | 169 | buildUi :: AppState -> Box 170 | buildUi appst = 171 | let header = text titleAttr (" " ++ (storePath $ appStore appst) ++ " ") 172 | <++> hFill titleAttr '-' 1 173 | <++> text titleAttr " Store Manager " 174 | status = text bodyAttr $ maybe "" id $ mDesc $ getSelectedMigration appst 175 | helpBar = text titleAttr "q:quit e:edit " 176 | <++> hFill titleAttr '-' 1 177 | in header 178 | <--> appMigrationList appst 179 | <--> helpBar 180 | <--> status 181 | 182 | uiFromState :: AppM Box 183 | uiFromState = buildUi <$> get 184 | 185 | readStore :: FilesystemStore -> IO StoreData 186 | readStore store = do 187 | result <- loadMigrations store 188 | case result of 189 | Left es -> do 190 | putStrLn "There were errors in the migration store:" 191 | forM_ es $ \err -> do 192 | putStrLn $ " " ++ show err 193 | exitFailure 194 | Right theStoreData -> return theStoreData 195 | 196 | mkState :: FilesystemStore -> IO AppState 197 | mkState fsStore = do 198 | vty <- mkVty 199 | sz <- display_bounds $ terminal vty 200 | storeData <- readStore fsStore 201 | let migrationList = mkSimpleList bodyAttr selAttr (appropriateListWindow sz) migrationNames 202 | migrationNames = Map.keys $ storeDataMapping storeData 203 | return $ AppState { appStoreData = storeData 204 | , appStore = fsStore 205 | , appMigrationList = migrationList 206 | , appVty = vty 207 | } 208 | 209 | appropriateListWindow :: DisplayRegion -> Int 210 | appropriateListWindow sz = fromEnum $ region_height sz - 3 211 | 212 | main :: IO () 213 | main = do 214 | args <- getArgs 215 | 216 | when (length args /= 1) $ do 217 | p <- getProgName 218 | putStrLn ("Usage: " ++ p ++ " ") 219 | exitFailure 220 | 221 | let store = FSStore { storePath = args !! 0 } 222 | 223 | beginState <- mkState store 224 | 225 | -- Capture the new application state because it might contain a new 226 | -- Vty. 227 | endState <- execStateT (eventloop uiFromState handleEvent) beginState 228 | let endVty = appVty endState 229 | 230 | -- Clear the screen. 231 | reserve_display $ terminal endVty 232 | shutdown endVty -------------------------------------------------------------------------------- /src/Moo/CommandUtils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts, OverloadedStrings #-} 2 | module Moo.CommandUtils 3 | ( apply 4 | , confirmCreation 5 | , interactiveAskDeps 6 | , lookupMigration 7 | , revert 8 | , withBackend 9 | , getCurrentTimestamp 10 | ) where 11 | 12 | import Data.Text ( Text ) 13 | import qualified Data.Text as T 14 | import Data.String.Conversions ( cs, (<>) ) 15 | 16 | import Control.Exception ( finally ) 17 | import Control.Monad ( when, forM_, unless ) 18 | import Control.Monad.Reader ( asks ) 19 | import Control.Monad.Trans ( liftIO ) 20 | import Data.List ( intercalate, sortBy, isPrefixOf ) 21 | import Data.Time.Clock (getCurrentTime) 22 | import Data.Maybe ( fromJust, isJust ) 23 | import System.Exit ( exitWith, ExitCode(..) ) 24 | import System.IO ( stdout, hFlush, hGetBuffering 25 | , hSetBuffering, stdin, BufferMode(..) ) 26 | 27 | import Database.Schema.Migrations ( migrationsToApply, migrationsToRevert ) 28 | import Database.Schema.Migrations.Backend (Backend(..)) 29 | import Database.Schema.Migrations.Migration ( Migration(..) ) 30 | import Database.Schema.Migrations.Store ( StoreData 31 | , storeLookup 32 | , storeMigrations 33 | ) 34 | import Moo.Core 35 | 36 | getCurrentTimestamp :: IO Text 37 | getCurrentTimestamp = 38 | cs . replace ":" "-" . replace " " "_" . take 19 . show <$> getCurrentTime 39 | 40 | apply :: Migration -> StoreData -> Backend -> Bool -> IO [Migration] 41 | apply m storeData backend complain = do 42 | -- Get the list of migrations to apply 43 | toApply <- migrationsToApply storeData backend m 44 | 45 | -- Apply them 46 | if null toApply then 47 | nothingToDo >> return [] else 48 | mapM_ (applyIt backend) toApply >> return toApply 49 | 50 | where 51 | nothingToDo = 52 | when complain $ 53 | putStrLn . cs $ "Nothing to do; " <> 54 | mId m <> 55 | " already installed." 56 | 57 | applyIt conn it = do 58 | putStr . cs $ "Applying: " <> mId it <> "... " 59 | applyMigration conn it 60 | putStrLn "done." 61 | 62 | revert :: Migration -> StoreData -> Backend -> IO [Migration] 63 | revert m storeData backend = do 64 | -- Get the list of migrations to revert 65 | toRevert <- liftIO $ migrationsToRevert storeData backend m 66 | 67 | -- Revert them 68 | if null toRevert then 69 | nothingToDo >> return [] else 70 | mapM_ (revertIt backend) toRevert >> return toRevert 71 | 72 | where 73 | nothingToDo = 74 | putStrLn . cs $ "Nothing to do; " <> 75 | mId m <> 76 | " not installed." 77 | 78 | revertIt conn it = do 79 | putStr . cs $ "Reverting: " <> mId it <> "... " 80 | revertMigration conn it 81 | putStrLn "done." 82 | 83 | 84 | lookupMigration :: StoreData -> Text -> IO Migration 85 | lookupMigration storeData name = do 86 | let theMigration = storeLookup storeData name 87 | case theMigration of 88 | Nothing -> do 89 | putStrLn . cs $ "No such migration: " <> name 90 | exitWith (ExitFailure 1) 91 | Just m' -> return m' 92 | 93 | -- Given an action that needs a database connection, connect to the 94 | -- database using the backend and invoke the action 95 | -- with the connection. Return its result. 96 | withBackend :: (Backend -> IO a) -> AppT a 97 | withBackend act = do 98 | backend <- asks _appBackend 99 | liftIO $ (act backend) `finally` (disconnectBackend backend) 100 | 101 | -- Given a migration name and selected dependencies, get the user's 102 | -- confirmation that a migration should be created. 103 | confirmCreation :: Text -> [Text] -> IO Bool 104 | confirmCreation migrationId deps = do 105 | putStrLn "" 106 | putStrLn . cs $ "Confirm: create migration '" <> migrationId <> "'" 107 | if null deps then putStrLn " (No dependencies)" 108 | else putStrLn "with dependencies:" 109 | forM_ deps $ \d -> putStrLn . cs $ " " <> d 110 | prompt "Are you sure?" [ ('y', (True, Nothing)) 111 | , ('n', (False, Nothing)) 112 | ] 113 | 114 | -- Prompt the user for a choice, given a prompt and a list of possible 115 | -- choices. Let the user get help for the available choices, and loop 116 | -- until the user makes a valid choice. 117 | prompt :: (Eq a) => String -> PromptChoices a -> IO a 118 | prompt _ [] = error "prompt requires a list of choices" 119 | prompt message choiceMap = do 120 | putStr $ message ++ " (" ++ choiceStr ++ helpChar ++ "): " 121 | hFlush stdout 122 | c <- unbufferedGetChar 123 | case lookup c choiceMap of 124 | Nothing -> do 125 | when (c /= '\n') $ putStrLn "" 126 | when (c == 'h') $ putStr $ mkPromptHelp choiceMapWithHelp 127 | retry 128 | Just (val, _) -> putStrLn "" >> return val 129 | where 130 | retry = prompt message choiceMap 131 | choiceStr = intercalate "" $ map (return . fst) choiceMap 132 | helpChar = if hasHelp choiceMap then "h" else "" 133 | choiceMapWithHelp = choiceMap ++ [('h', (undefined, Just "this help"))] 134 | 135 | -- Given a PromptChoices, build a multi-line help string for those 136 | -- choices using the description information in the choice list. 137 | mkPromptHelp :: PromptChoices a -> String 138 | mkPromptHelp choices = 139 | intercalate "" [ [c] ++ ": " ++ fromJust msg ++ "\n" | 140 | (c, (_, msg)) <- choices, isJust msg ] 141 | 142 | -- Does the specified prompt choice list have any help messages in it? 143 | hasHelp :: PromptChoices a -> Bool 144 | hasHelp = (> 0) . length . filter hasMsg 145 | where hasMsg (_, (_, m)) = isJust m 146 | 147 | -- A general type for a set of choices that the user can make at a 148 | -- prompt. 149 | type PromptChoices a = [(Char, (a, Maybe String))] 150 | 151 | -- Get an input character in non-buffered mode, then restore the 152 | -- original buffering setting. 153 | unbufferedGetChar :: IO Char 154 | unbufferedGetChar = do 155 | bufferingMode <- hGetBuffering stdin 156 | hSetBuffering stdin NoBuffering 157 | c <- getChar 158 | hSetBuffering stdin bufferingMode 159 | return c 160 | 161 | -- The types for choices the user can make when being prompted for 162 | -- dependencies. 163 | data AskDepsChoice = Yes | No | View | Done | Quit 164 | deriving (Eq) 165 | 166 | -- Interactively ask the user about which dependencies should be used 167 | -- when creating a new migration. 168 | interactiveAskDeps :: StoreData -> IO [Text] 169 | interactiveAskDeps storeData = do 170 | -- For each migration in the store, starting with the most recently 171 | -- added, ask the user if it should be added to a dependency list 172 | let sorted = sortBy compareTimestamps $ storeMigrations storeData 173 | interactiveAskDeps' storeData (map mId sorted) 174 | where 175 | compareTimestamps m1 m2 = compare (mTimestamp m2) (mTimestamp m1) 176 | 177 | -- Recursive function to prompt the user for dependencies and let the 178 | -- user view information about potential dependencies. Returns a list 179 | -- of migration names which were selected. 180 | interactiveAskDeps' :: StoreData -> [Text] -> IO [Text] 181 | interactiveAskDeps' _ [] = return [] 182 | interactiveAskDeps' storeData (name:rest) = do 183 | result <- prompt ("Depend on '" ++ cs name ++ "'?") askDepsChoices 184 | if result == Done then return [] else 185 | case result of 186 | Yes -> do 187 | next <- interactiveAskDeps' storeData rest 188 | return $ name:next 189 | No -> interactiveAskDeps' storeData rest 190 | View -> do 191 | -- load migration 192 | let Just m = storeLookup storeData name 193 | -- print out description, timestamp, deps 194 | when (isJust $ mDesc m) 195 | (putStrLn . cs $ " Description: " <> 196 | fromJust (mDesc m)) 197 | putStrLn $ " Created: " ++ show (mTimestamp m) 198 | unless (null $ mDeps m) 199 | (putStrLn . cs $ " Deps: " <> 200 | T.intercalate "\n " (mDeps m)) 201 | -- ask again 202 | interactiveAskDeps' storeData (name:rest) 203 | Quit -> do 204 | putStrLn "cancelled." 205 | exitWith (ExitFailure 1) 206 | Done -> return [] 207 | 208 | -- The choices the user can make when being prompted for dependencies. 209 | askDepsChoices :: PromptChoices AskDepsChoice 210 | askDepsChoices = [ ('y', (Yes, Just "yes, depend on this migration")) 211 | , ('n', (No, Just "no, do not depend on this migration")) 212 | , ('v', (View, Just "view migration details")) 213 | , ('d', (Done, Just "done, do not ask me about more dependencies")) 214 | , ('q', (Quit, Just "cancel this operation and quit")) 215 | ] 216 | 217 | -- The following code is vendored from MissingH Data.List.Utils: 218 | 219 | {- | Similar to Data.List.span, but performs the test on the entire remaining 220 | list instead of just one element. 221 | 222 | @spanList p xs@ is the same as @(takeWhileList p xs, dropWhileList p xs)@ 223 | -} 224 | spanList :: ([a] -> Bool) -> [a] -> ([a], [a]) 225 | 226 | spanList _ [] = ([],[]) 227 | spanList func list@(x:xs) = 228 | if func list 229 | then (x:ys,zs) 230 | else ([],list) 231 | where (ys,zs) = spanList func xs 232 | 233 | {- | Similar to Data.List.break, but performs the test on the entire remaining 234 | list instead of just one element. 235 | -} 236 | breakList :: ([a] -> Bool) -> [a] -> ([a], [a]) 237 | breakList func = spanList (not . func) 238 | 239 | replace :: Eq a => [a] -> [a] -> [a] -> [a] 240 | replace old new = intercalate new . split old 241 | 242 | split :: Eq a => [a] -> [a] -> [[a]] 243 | split _ [] = [] 244 | split delim str = 245 | let (firstline, remainder) = breakList (isPrefixOf delim) str 246 | in firstline : case remainder of 247 | [] -> [] 248 | x -> if x == delim 249 | then [[]] 250 | else split delim (drop (length delim) x) 251 | -------------------------------------------------------------------------------- /MOO.TXT: -------------------------------------------------------------------------------- 1 | 2 | moo: the dbmigrations management tools 3 | ------------------------------------------ 4 | 5 | The database type specific package that work as a companion to this 6 | library contain tools called "moo-postgresql", "moo-mysql", "moo-sqlite", 7 | etc. They are responsible for creating, installing, and reverting migrations 8 | in your database backend. Since all of these command line tools offer the 9 | exact same interface, they are described here in a single document. 10 | The executables mentioned above are simply called "moo" for the rest of 11 | this document. That is, given an example that reads as "moo command" you 12 | actually have to execute "moo-postgresql command" or "moo-mysql command" 13 | and so on. 14 | 15 | At present, MySQL, PostgreSQL and Sqlite3 are the only supported database 16 | backends. 17 | 18 | The moo tools work by creating migration files in a specific location, 19 | called a migration store, on your filesystem. This directory is where 20 | all possible migrations for your project will be kept. Moo allows you to 21 | create migrations that depend on each other. When you use moo to upgrade 22 | your database schema, it determines which migrations are missing, what 23 | their dependencies are, and installs the required migrations in the 24 | correct order (based on dependencies). 25 | 26 | Moo works by prompting you for new migration information. It then 27 | creates a migration YAML file (whose format is described below), which 28 | you then edit by hand. 29 | 30 | When migrations are installed into your database, the set of installed 31 | migrations is tracked by way of a migration table that is installed into 32 | your database. 33 | 34 | 35 | Using dbmigrations with MySQL 36 | ----------------------------- 37 | 38 | While dbmigrations supports MySQL in general, the moo executable in this 39 | package does not work with a MySQL backend directly. MySQL support has 40 | been factored out into a separate package, called dbmigrations-mysql. 41 | If you want to apply migrations to a MySQL backend, please install and 42 | use dbmigrations-mysql instead of this package. The reason is that the 43 | MySQL support depends on MySQL Haskell libraries which in turn have 44 | build dependencies that make it necessary for MySQL itself to be 45 | installed during build time. 46 | 47 | 48 | Getting started 49 | --------------- 50 | 51 | 1. Create a directory in which to store migration files. 52 | 53 | 2. Set an environment variable DBM_MIGRATION_STORE to the path to the 54 | directory you created in step 1. 55 | 56 | 3. Set an environment variable DBM_DATABASE to a database connection 57 | string that is appropriate for the database type you 58 | chose. The contents of this depend on the database type, see the 59 | "Environment" documentation section for more information. 60 | 61 | 4. Run "moo upgrade". This command will not actually install any 62 | migrations, since you have not created any, but it will attempt to 63 | connect to your database and install a migration-tracking table. 64 | 65 | If this step succeeds, you should see this output: 66 | 67 | Database is up to date. 68 | 69 | 5. Create a migration with "moo new". Here is an example output: 70 | 71 | $ moo new hello-world 72 | Selecting dependencies for new migration: hello-world 73 | 74 | Confirm: create migration 'hello-world' 75 | (No dependencies) 76 | Are you sure? (yn): y 77 | Migration created successfully: ".../hello-world.yml" 78 | 79 | New migration will be stored with .yml extension. Older .txt migrations are supported. 80 | 81 | 6. Edit the migration you created. In this case, moo created a file 82 | $DBM_MIGRATION_STORE/hello_world.yml that looks like this: 83 | 84 | Description: (Description here.) 85 | Created: 2015-02-18 00:50:12.041176 UTC 86 | Depends: 87 | Apply: | 88 | (Apply SQL here.) 89 | 90 | Revert: | 91 | (Revert SQL here.) 92 | 93 | This migration has no valid apply or revert SQL yet; that's for you 94 | to provide. You might edit the apply and revert fields as follows: 95 | 96 | Apply: | 97 | CREATE TABLE foo (a int); 98 | 99 | Revert: | 100 | DROP TABLE foo; 101 | 102 | 7. Test the new migration with "moo test". This will install the 103 | migration in a transaction and roll it back. Here is example output: 104 | 105 | $ moo test hello-world 106 | Applying: hello-world... done. 107 | Reverting: hello-world... done. 108 | Successfully tested migrations. 109 | 110 | 8. Install the migration. This can be done in one of two ways: with 111 | "moo upgrade" or with "moo apply". Here are examples: 112 | 113 | $ moo apply hello-world 114 | Applying: hello-world... done. 115 | Successfully applied migrations. 116 | 117 | $ moo upgrade 118 | Applying: hello-world... done. 119 | Database successfully upgraded. 120 | 121 | 9. List installed migrations with "moo list". 122 | 123 | $ moo list 124 | hello-world 125 | 126 | 10. Revert the migration. 127 | 128 | $ moo revert hello-world 129 | Reverting: hello-world... done. 130 | Successfully reverted migrations. 131 | 132 | 11. List migrations that have not been installed. 133 | 134 | $ moo upgrade-list 135 | Migrations to install: 136 | hello-world 137 | 138 | Configuration file format 139 | ------------------------- 140 | 141 | All moo commands accept a --config-file option which you can use to 142 | specify the path to a configuration file containing your settings. This 143 | approach is an alternative to setting environment variables. The 144 | configuration file format uses the same environment variable names for 145 | its fields. An example configuration is as follows: 146 | 147 | DBM_DATABASE = "/path/to/database.db" 148 | DBM_MIGRATION_STORE = "/path/to/migration/store" 149 | DBM_LINEAR_MIGRATIONS = on/off (or true/false; defaults to off) 150 | DBM_TIMESTAMP_FILENAMES = on/off (or true/false; defaults to off) 151 | 152 | Alternatively, you may save your settings to "moo.cfg" file in the current 153 | directory (probably a project root) and moo will load it automatically, if 154 | present. Specifying --config-file disables this behavior. 155 | 156 | If you use a config file (either the default one or the one specified with 157 | --config-file option) but the environment variables are set, they will 158 | override settings from the file. You may use this to have project settings 159 | specified in a file and use environment to specify user-local configuration 160 | options. 161 | 162 | Migration file format 163 | --------------------- 164 | 165 | A migration used by this package is a structured document in YAML 166 | format containing these fields: 167 | 168 | Description: (optional) a textual description of the migration 169 | 170 | Dependencies: (required, but may be empty) a whitespace-separated 171 | list of migration names on which the migration 172 | depends; these names are the migration filenames 173 | without the filename extension 174 | 175 | Created: The UTC date and time at which this migration was 176 | created 177 | 178 | Apply: The SQL necessary to apply this migration to the 179 | database 180 | 181 | Revert: (optional) The SQL necessary to revert this migration 182 | from the database 183 | 184 | The format of this file is somewhat flexible; please see the YAML 1.2 185 | format specification for a full description of syntax features. I 186 | recommend appending "|" to the Apply and Revert fields if they contain 187 | multi-line SQL that you want to keep that way, e.g., 188 | 189 | Apply: | 190 | CREATE OR REPLACE FUNCTION ... 191 | ... 192 | ... 193 | 194 | Revert: | 195 | DROP TABLE foo; 196 | DROP TABLE bar; 197 | 198 | Note that this is only *necessary* when concatenating the lines would 199 | have a different meaning, e.g., 200 | 201 | Apply: 202 | -- Comment here 203 | CREATE TABLE; 204 | 205 | Without "|" on the "Apply:" line, the above text would be collapsed to 206 | "-- Comment here CREATE TABLE;" which is probably not what you want. 207 | For a full treatment of this behavior, see the YAML spec. 208 | 209 | Environment 210 | ----------- 211 | 212 | Moo depends on these environment variables / configuration file 213 | settings: 214 | 215 | DBM_DATABASE 216 | 217 | The database connection string for the database you'll be 218 | managing. The connection strings for each supported database type 219 | are as follows: 220 | 221 | PostgreSQL: 222 | 223 | The format of this value is a PostgreSQL database connection 224 | string, i.e., that described at: 225 | 226 | http://www.postgresql.org/docs/8.1/static/libpq.html#LIBPQ-CONNECT 227 | 228 | SQlite3: 229 | 230 | The format of this value is a filesystem path to the Sqlite3 231 | database to be used. 232 | 233 | MySQL: 234 | 235 | For MySQL, DBM_DATABASE should be a value of key value pairs, 236 | where each pair is formed by `key=value`, and each pair separated 237 | by a semicolon. Required keys are `host`, `user` and `database`, 238 | and you can optionally supply `port` and `password`. 239 | 240 | Example: DBM_DATABASE="host=localhost; user=root; database=cows" 241 | 242 | DBM_MIGRATION_STORE 243 | 244 | The path to the filesystem directory where your migrations will be 245 | kept. moo will create new migrations in this directory and use 246 | the migrations in this directory when updating the database 247 | schema. Initially, you'll probably set this to an extant (but 248 | empty) directory. moo will not create it for you. 249 | 250 | DBM_LINEAR_MIGRATIONS 251 | 252 | If set to true/on, the linear migrations feature will be enabled. 253 | Defaults to off. See 'Linear migrations' section for more details. 254 | 255 | DBM_TIMESTAMP_FILENAMES 256 | 257 | If set to true/on, the migration filename for new migrations will 258 | have a timestamp embedded in it. 259 | 260 | Commands 261 | -------- 262 | 263 | new : create a new migration with the given name and 264 | save it in the migration store. This command will prompt you for 265 | dependencies on other migrations (if the 'linear migrations' 266 | feature is disabled) and ask for confirmation before creating the 267 | migration in the store. If you use the --no-ask flag, the migration 268 | will be created immediately with no dependencies. 269 | 270 | apply : apply the specified migration (and its 271 | dependencies) to the database. This operation will be performed 272 | in a single transaction which will be rolled back if an error 273 | occurs. moo will output updates as each migration is applied. 274 | 275 | revert : revert the specified migration (and its 276 | reverse dependencies -- the migrations which depend on it) from 277 | the database. This operation will be performed in a single 278 | transaction which will be rolled back if an error occurs. moo 279 | will output updates as each migration is reverted. 280 | 281 | test : once you've created a migration, you might 282 | find it useful to test the migration to be sure that it is 283 | syntactically valid; the "test" command will apply the specified 284 | migration and revert it (if revert SQL is specified in the 285 | migration). It will perform both of these operations in a 286 | transaction and then issue a rollback. 287 | 288 | upgrade: this will apply all migrations in the migration store which 289 | have not yet been applied to the database. Each migration will be 290 | applied with its dependenciees in the correct order. All of the 291 | migrations will be applied together in a single transaction. By 292 | default, this transaction is committed; if you use the --test 293 | flag, the transaction will be rolled back, allowing you to test 294 | the entire upgrade process. 295 | 296 | upgrade-list: this will list the migrations that the "upgrade" 297 | command would apply if you were to run it. In other words, this 298 | will list all migrations which have not yet been applied to the 299 | database. 300 | 301 | reinstall: this will revert, then reapply a migration, all in a 302 | transaction. If --test is specified, the transaction will be 303 | rolled back; otherwise it will be committed. This is mostly 304 | useful in development when a migration applies but is incorrect 305 | and needs to be tweaked and reapplied. 306 | 307 | Linear migrations 308 | ----------------- 309 | 310 | If you know that every migration needs to depend on all previous ones, 311 | consider enabling this feature. When enabled, 'moo new' will automatically 312 | select smallest subset of existing migrations that will make the new one 313 | indirectly depend on every other already in the store. This in turn makes 314 | the store linear-ish (in terms of order of execution) and helps managing the 315 | migrations by always depending on previous work. Also, this may easily be used 316 | to see how the database changed in time. 317 | --------------------------------------------------------------------------------