diff --git a/main/Add.hs b/main/Add.hs --- a/main/Add.hs +++ b/main/Add.hs @@ -1,3 +1,13 @@ +-- | +-- Module: Add +-- Copyright: (c) 2015 Mark Fine +-- License: MIT +-- Maintainer: Mark Fine +-- Stability: experimental +-- Portability: portable +-- +-- Tool for adding PostgreSQL migrations. + import BasePrelude import Data.Text ( pack ) import Data.Time.Clock ( getCurrentTime ) @@ -9,6 +19,7 @@ data Args = Args { aFile :: String + , aName :: Maybe String , aDir :: Maybe String } deriving ( Eq, Read, Show ) @@ -24,24 +35,29 @@ <> metavar "FILE" <> help "Migration File" ) <*> optional ( strOption + ( long "name" + <> metavar "NAME" + <> help "Migration Name" ) ) + <*> optional ( strOption ( long "dir" <> metavar "DIR" <> help "Migrations Directory" ) ) -newMigration :: IO String -newMigration = do - now <- getCurrentTime - return $ formatTime defaultTimeLocale "%Y%m%d-%H%M%S.sql" now - -exec :: String -> String -> IO () -exec file dir = do - migration <- newMigration +exec :: String -> String -> String -> IO () +exec migration file dir = shelly $ add (fromText (pack migration)) (fromText (pack file)) (fromText (pack dir)) +newMigration :: Maybe String -> IO String +newMigration name = do + now <- getCurrentTime + return $ intercalate "-" ( timestamp now : maybeToList name ) ++ ".sql" where + timestamp = formatTime defaultTimeLocale "%Y%m%d-%H%M%S" + main :: IO () main = execParser args >>= call where - call Args{..} = - exec aFile (fromMaybe "migrations" aDir) + call Args{..} = do + migration <- newMigration aName + exec migration aFile (fromMaybe "migrations" aDir) diff --git a/main/Apply.hs b/main/Apply.hs --- a/main/Apply.hs +++ b/main/Apply.hs @@ -1,3 +1,13 @@ +-- | +-- Module: Apply +-- Copyright: (c) 2015 Mark Fine +-- License: MIT +-- Maintainer: Mark Fine +-- Stability: experimental +-- Portability: portable +-- +-- Tool for applying PostgreSQL migrations. + import BasePrelude hiding ( FilePath ) import Data.Text ( Text, pack ) import Database.PostgreSQL.Schema ( bootstrap, converge ) diff --git a/postgresql-schema.cabal b/postgresql-schema.cabal --- a/postgresql-schema.cabal +++ b/postgresql-schema.cabal @@ -1,5 +1,5 @@ name: postgresql-schema -version: 0.1.1 +version: 0.1.3 synopsis: PostgreSQL Schema Management description: Please see README.md homepage: https://github.com/mfine/postgresql-schema diff --git a/src/Database/PostgreSQL/Schema.hs b/src/Database/PostgreSQL/Schema.hs --- a/src/Database/PostgreSQL/Schema.hs +++ b/src/Database/PostgreSQL/Schema.hs @@ -1,5 +1,18 @@ +-- | +-- Module: Database.PostgreSQL.Schema +-- Copyright: (c) 2015 Mark Fine +-- License: MIT +-- Maintainer: Mark Fine +-- Stability: experimental +-- Portability: portable +-- +-- Functions for working with PostgreSQL migrations. + module Database.PostgreSQL.Schema - ( add + ( + -- * Adding Migrations + add + -- * Applying Migrations , bootstrap , converge ) where @@ -9,6 +22,9 @@ import Formatting ( (%), sformat, stext ) import Shelly + +-- psql + psqlCommand :: Text -> Text -> Sh Text psqlCommand c url = run "psql" [ "--no-align" @@ -26,20 +42,15 @@ , toTextIgnore f , url ] + +-- SQL + countSchema :: Text -> Text -countSchema schema = +countSchema = sformat ( " SELECT count(*) " % " FROM pg_namespace " % " WHERE nspname = '" % stext % "' " ) - schema -countMigration :: FilePath -> Text -> Text -> Text -countMigration migration table schema = - sformat ( " SELECT count(*) " % - " FROM " % stext % "." % stext % - " WHERE filename = '" % stext % "' " ) - schema table (toTextIgnore migration) - insertMigration :: FilePath -> Text -> Text -> Text insertMigration migration table schema = sformat ( " INSERT INTO " % stext % "." % stext % " (filename) " % @@ -58,65 +69,80 @@ intercalate ", " $ flip map migrations $ \migration -> sformat ("'" % stext % "'") (toTextIgnore migration) + +-- psql + SQL + checkSchema :: Text -> Text -> Sh Bool checkSchema schema url = do r <- psqlCommand (countSchema schema) url return $ strip r == "0" -checkMigration :: FilePath -> Text -> Text -> Text -> Sh Bool -checkMigration migration table schema url = do - r <- psqlCommand (countMigration migration table schema) url - return $ strip r == "0" - -getMigrations :: [FilePath] -> Text -> Text -> Text -> Sh [FilePath] -getMigrations migrations table schema url = do +filterMigrations :: [FilePath] -> Text -> Text -> Text -> Sh [FilePath] +filterMigrations migrations table schema url = do r <- psqlCommand (selectMigrations migrations table schema) url return $ migrations \\ map fromText (lines r) + +-- migrations + findMigrations :: FilePath -> Sh [FilePath] findMigrations dir = do migrations <- findWhen test_f dir forM migrations $ relativeTo dir -migrate :: FilePath -> FilePath -> Text -> Text -> Text -> Sh () -migrate migration dir table schema url = do - contents <- readfile migration - appendfile (dir migration) "\\set ON_ERROR_STOP true\n\n" - appendfile (dir migration) contents - appendfile (dir migration) $ insertMigration migration table schema - psqlFile (dir migration) url - -migrateWithCheck :: [FilePath] -> Text -> Text -> Text -> Sh () -migrateWithCheck migrations table schema url = +migrate :: [FilePath] -> Text -> Text -> Text -> Sh () +migrate migrations table schema url = withTmpDir $ \dir -> forM_ migrations $ \migration -> do - check <- checkMigration migration table schema url - when check $ - migrate migration dir table schema url + echo $ out migration + contents <- readfile migration + appendfile (dir migration) "\\set ON_ERROR_STOP true\n\n" + appendfile (dir migration) contents + appendfile (dir migration) $ insertMigration migration table schema + psqlFile (dir migration) url where + out migration = + sformat ( "M " % stext % " -> " % stext ) + (toTextIgnore migration) table -migrateWithoutCheck :: [FilePath] -> Text -> Text -> Text -> Sh () -migrateWithoutCheck migrations table schema url = - withTmpDir $ \dir -> - forM_ migrations $ \migration -> - migrate migration dir table schema url +-- API + +-- | Add a DDL migration file to a migrations directory. Fails if +-- migration file or migrations directory do not exist. +add :: FilePath -> FilePath -> FilePath -> Sh () +add migration file dir = do + echo out + mv file (dir migration) where + out = + sformat ( "A " % stext % " -> " % stext ) + (toTextIgnore file) + (toTextIgnore (dir migration)) + +-- | Apply bootstrap migrations to a database. Checks if a database +-- has been previously bootstrapped, and applies all bootstrap +-- migrations if it has not been previously bootstrapped. Applies +-- all bootstrap migrations that have not been applied yet and records +-- their application. bootstrap :: FilePath -> Text -> Text -> Text -> Sh () bootstrap dir table schema url = do migrations <- findMigrations dir chdir dir $ do check <- checkSchema schema url - when check $ - migrateWithoutCheck migrations table schema url - migrations' <- getMigrations migrations table schema url - migrateWithCheck migrations' table schema url + when check $ do + echo "Bootstrapping..." + migrate migrations table schema url + migrations' <- filterMigrations migrations table schema url + unless (null migrations') $ do + echo "Bootstrap migrating..." + migrate migrations' table schema url +-- | Apply migrations to a database. Applies all migrations that have +-- not been applied yet and records their application. converge :: FilePath -> Text -> Text -> Text -> Sh () converge dir table schema url = do migrations <- findMigrations dir chdir dir $ do - migrations' <- getMigrations migrations table schema url - migrateWithCheck migrations' table schema url - -add :: FilePath -> FilePath -> FilePath -> Sh () -add migration file dir = - mv file (dir migration) + migrations' <- filterMigrations migrations table schema url + unless (null migrations') $ do + echo "Migrating..." + migrate migrations' table schema url