diff --git a/database-migrate.cabal b/database-migrate.cabal --- a/database-migrate.cabal +++ b/database-migrate.cabal @@ -1,5 +1,5 @@ Name: database-migrate -Version: 0.0.1 +Version: 0.0.2 License: BSD3 License-File: LICENSE Author: Mark Hibberd @@ -9,16 +9,16 @@ Category: Database Homepage: https://github.com/markhibberd/database-migrate Bug-reports: https://github.com/markhibberd/database-migrate/issues -Cabal-Version: >= 1.6 +Cabal-Version: >= 1.8 Build-Type: Simple Description: A database versioning and migration library. . - /Note/: that this library is under heavy development, currently + /Note/: This library is under heavy development, currently the PostgreSQL implementation is functional, but expected to change. It is intended that a type safe - migration api and command line tools be added to this - library before it be considered stable. + migration api, command line tools and MySql support be added + before this library will be considered stable. Source-Repository head Type: git @@ -29,7 +29,7 @@ Library Build-Depends: - base >= 3 && < 5 + base >= 3 && < 5 , text >= 0.11 && < 0.12 , directory >= 1.0 && < 2.0 , filepath >= 1.0 && < 2.0 @@ -39,6 +39,7 @@ , containers >= 0.4 && < 0.5 , either >= 3.0.2 && < 4.0 , transformers >= 0.2 && < 0.4 + , cmdargs >= 0.9.3 && < 1.0.0 GHC-Options: -Wall -fno-warn-orphans @@ -48,6 +49,7 @@ Exposed-Modules: Database.Migrate + Database.Migrate.Main Database.Migrate.Core Database.Migrate.PostgreSQL @@ -56,3 +58,14 @@ OverloadedStrings +Executable migrate + Main-Is: main.hs + Hs-Source-Dirs: src + Ghc-Options: -Wall -O2 + Build-Depends: + base >= 3 && < 5 + , database-migrate + , cmdargs >= 0.9.3 && < 1.0.0 + , directory >= 1.0 && < 2.0 + , postgresql-simple >= 0.1 && < 1.0 + , text >= 0.11 && < 0.12 diff --git a/src/Database/Migrate.hs b/src/Database/Migrate.hs --- a/src/Database/Migrate.hs +++ b/src/Database/Migrate.hs @@ -8,14 +8,17 @@ -- A library to assist with managing database versioning -- and migration. -- --- Note: This library is under heavy development, currently --- the PostgreSQL implementation is functional, but --- expected to change. It is intended that a type safe --- migration api and command line tools be added to this --- library before it be considered stable. +-- /Note/: This library is under heavy development, currently +-- the PostgreSQL implementation is functional, but +-- expected to change. It is intended that a type safe +-- migration api, command line tools and MySql support be added +-- before this library will be considered stable. +-- module Database.Migrate (module X) where +import Database.Migrate.Main as X import Database.Migrate.Core as X -- import Database.Migrate.MySQL as X import Database.Migrate.PostgreSQL as X + diff --git a/src/Database/Migrate/Core.hs b/src/Database/Migrate/Core.hs --- a/src/Database/Migrate/Core.hs +++ b/src/Database/Migrate/Core.hs @@ -1,4 +1,4 @@ -{-#LANGUAGE OverloadedStrings #-} +{-#LANGUAGE OverloadedStrings, ScopedTypeVariables#-} module Database.Migrate.Core where import Control.Monad @@ -7,13 +7,22 @@ import Control.Monad.Trans.Either import qualified Data.Set as S +import Data.List (sort) import Data.Text hiding (foldr, filter, reverse, length) import System.FilePath import System.Directory import System.IO -type MigrationId = Text +data MigrationId = + MigrationId { extract :: Text } deriving (Eq, Show) + +instance Ord MigrationId where + compare a b = + case (reads . unpack . extract $ a, reads . unpack . extract $ b) of + ([(i :: Int, "")], [(j :: Int, "")]) -> compare i j + _ -> compare (extract a) (extract b) + type Ddl = Text data Migration = @@ -23,8 +32,11 @@ , down :: Text , upsource :: Maybe FilePath , downsource :: Maybe FilePath - } + } deriving (Eq, Show) +instance Ord Migration where + compare a b = compare (migration a) (migration b) + data Context = Context { succeeded :: [MigrationId] , failed :: MigrationId @@ -51,18 +63,19 @@ lift (getMigrations c) >>= \installed -> runMigrations c up (pick migrations installed) find :: FilePath -> EitherT String IO [Migration] -find b = liftIO (getDirectoryContents b) >>= \fs -> liftIO (migrationids b fs) >>= +find b = liftIO (getDirectoryContents b) >>= \fs -> liftM sort (liftIO (migrationids b fs) >>= mapM (\p -> do downexists <- liftIO $ doesFileExist (b p <.> "down.sql") unless downexists (left $ "no down.sql for migration [" ++ p ++ "]") u <- liftIO . readFile $ b p <.> "up.sql" d <- liftIO . readFile $ b p <.> "down.sql" - right (Migration (pack p) (pack u) (pack d) (Just $ b p <.> "up.sql") (Just $ b p <.> "down.sql"))) + right (Migration (MigrationId . pack $ p) (pack u) (pack d) (Just $ b p <.> "up.sql") (Just $ b p <.> "down.sql")))) migrationids :: FilePath -> [FilePath] -> IO [String] migrationids b ps = filterM (\p -> doesFileExist (b p)) ps >>= \files -> - return (filter (\p -> takeExtensions p == ".up.sql" ) files) >>= \ups -> return (fmap dropExtensions ups) + ((return . fmap dropExtensions) + (filter (\p -> takeExtensions p == ".up.sql") files)) readFile' :: FilePath -> IO String readFile' p = withFile p ReadMode hGetContents diff --git a/src/Database/Migrate/Main.hs b/src/Database/Migrate/Main.hs new file mode 100644 --- /dev/null +++ b/src/Database/Migrate/Main.hs @@ -0,0 +1,78 @@ +module Database.Migrate.Main (defaultMain) where + +import qualified Paths_database_migrate as Program (version) + +import qualified Data.Text as T +import Data.Version (showVersion) + +import Database.PostgreSQL.Simple + +import System.Console.CmdArgs.Explicit +import System.Directory +import System.Exit + +usage = [ + "usage: migrate [-v|--verbose] [-r|--dry-run] [-t|--test-run] [-a|--auto] [-s|--scripts DIR]" + , " [-h|--host HOSTNAME] [-p|--port PORTNUMBER] [-u|--user USER]" + , " [-P|--password PASSWORD] [-d|--db DATABASE] [-g|--postgres] [-m|--mysql] [VERSION]" + , " migrate -h|--help" + , " migrate -V|--version" + ] + +data Arguments = Arguments { + printhelp :: Bool + , printversion :: Bool + , dry :: Bool + , test :: Bool + , auto :: Bool + , postgres :: Bool + , mysql :: Bool + , version :: Maybe String + , scripts :: String + } deriving (Eq, Show) + +defaultArguments cwd = Arguments { + printhelp = False + , printversion = False + , dry = False + , test = False + , auto = False + , postgres = False + , mysql = False + , version = Nothing + , scripts = cwd + } + +migratemode cwd = + mode "migrate" (defaultArguments cwd) "" (flagArg (\v a -> Right $ a { version = Just v }) "VERSION") [ + flagNone [ "h", "help" ] (\a -> a { printhelp = True }) "" + , flagNone [ "V", "version" ] (\a -> a { printversion = True }) "" + , flagNone [ "r", "dry-run" ] (\a -> a { dry = True }) "" + , flagNone [ "g", "postgres" ] (\a -> a { postgres = True }) "" + , flagNone [ "m", "mysql" ] (\a -> a { postgres = True }) "" + ] + +defaultMain = + getCurrentDirectory >>= \cwd -> processArgs (migratemode cwd) >>= run + +run args + | printhelp args = mapM_ putStrLn usage + | printversion args = putStrLn $ "migrate " ++ showVersion Program.version + | otherwise = migrate args + +bomb msg = + putStrLn msg >> exitFailure + +migrate args = + case (postgres args, mysql args) of + (False, False) -> bomb "Must specify exactly one of -p or -m for database selection, specified none." + (True, True) -> bomb "Must specify exactly one of -p or -m for database selection, specified two." + (True, _) -> runpostgres args + (_, True) -> runmysql args + +runmysql _ = + bomb "Not implemented yet." + +runpostgres args = + undefined + diff --git a/src/Database/Migrate/PostgreSQL.hs b/src/Database/Migrate/PostgreSQL.hs --- a/src/Database/Migrate/PostgreSQL.hs +++ b/src/Database/Migrate/PostgreSQL.hs @@ -6,29 +6,55 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Either -import Data.Text hiding (filter, reverse) +import Data.Text hiding (filter, reverse, find, null) import Data.String (IsString(..)) import Database.PostgreSQL.Simple +import Database.PostgreSQL.Simple.FromField +import Database.PostgreSQL.Simple.ToField import Database.Migrate.Core +instance FromField MigrationId where + fromField f m = fmap MigrationId $ fromField f m + +instance ToField MigrationId where + toField (MigrationId m) = toField m + instance MigrateDatabase IO Connection where initialize c = void $ execute_ c "CREATE TABLE IF NOT EXISTS MIGRATION_INFO (MIGRATION VARCHAR(50) PRIMARY KEY)" runMigrations = runall getMigrations c = fmap (fmap fromOnly) (query_ c "SELECT MIGRATION FROM MIGRATION_INFO") + +migratePostgres :: Connection -> FilePath -> (String -> IO ()) -> IO () -> IO () +migratePostgres c path logger bomb = do + initialize c + ems <- runEitherT $ find path + case ems of + Left e -> logger e >> bomb + Right ms -> runEitherT (latest c ms) >>= \er -> + case er of + Left (Context s f m r) -> + forM_ s (\mid -> logger ("migration:applied: " ++ (unpack . extract $ mid))) >> + logger ("migration:failed:" ++ (unpack . extract $ f) ++ ":" ++ unpack m) >> + logger ("migration:rolledback:" ++ show r) >> + bomb + Right mids -> if null mids + then logger "migration:up-to-date" + else forM_ mids $ \mid -> logger $ "migration:applied: " ++ (unpack . extract $ mid) + record :: Connection -> MigrationId -> IO () record conn mid = void $ execute conn "INSERT INTO MIGRATION_INFO VALUES (?)" (Only mid) runall :: Connection -> (Migration -> Ddl) -> [Migration] -> MigrationResultT IO [MigrationId] runall c f ms = liftIO (begin c) >> - (foldM (\rs m -> + foldM (\rs m -> EitherT $ do e <- runEitherT (saferun c f m) case e of Left emsg -> rollback c >> (return . Left $ Context (reverse rs) (migration m) emsg True) - Right r -> return . Right $ r:rs) [] ms) >>= \result -> liftIO (commit c) >> return (reverse result) + Right r -> return . Right $ r:rs) [] ms >>= \result -> liftIO (commit c) >> return (reverse result) saferun :: Connection -> (Migration -> Ddl) -> Migration -> EitherT Text IO MigrationId saferun c f m = EitherT $ handle (\e -> return (Left (pack . show $ (e :: SomeException)))) (fmap Right $ run c f m) diff --git a/src/main.hs b/src/main.hs new file mode 100644 --- /dev/null +++ b/src/main.hs @@ -0,0 +1,77 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +import qualified Paths_database_migrate as Program (version) + +import qualified Data.Text as T +import Data.Version (showVersion) + +import Database.PostgreSQL.Simple + +import System.Console.CmdArgs.Explicit +import System.Directory +import System.Exit + +usage = [ + "usage: migrate [-v|--verbose] [-d|--dry-run] [-t|--test-run] [-a|--auto] [-s|--scripts DIR]" + , " [-h|--host HOSTNAME] [-p|--port PORTNUMBER] [-u|--user USER] [-P|--password PASSWORD]" + , " " + , " [-g|--postgres] [-m|--mysql] [VERSION]" + , " migrate -h|--help" + , " migrate -V|--version" + ] + +data Arguments = Arguments { + printhelp :: Bool + , printversion :: Bool + , dry :: Bool + , test :: Bool + , auto :: Bool + , postgres :: Maybe String + , mysql :: Maybe String + , version :: Maybe String + , scripts :: String + } deriving (Eq, Show) + +defaultArguments cwd = Arguments { + printhelp = False + , printversion = False + , dry = False + , test = False + , auto = False + , postgres = Nothing + , mysql = Nothing + , version = Nothing + , scripts = cwd + } + +migratemode cwd = + mode "migrate" (defaultArguments cwd) "" (flagArg (\v a -> Right $ a { version = Just v }) "VERSION") [ + flagNone [ "h", "help" ] (\a -> a { printhelp = True }) "print help and exit" + , flagNone [ "V", "version" ] (\a -> a { printversion = True }) "print version and exit" + , flagNone [ "d", "dry-run" ] (\a -> a { dry = True }) "do not perform any updates" + ] + +main = + getCurrentDirectory >>= \cwd -> processArgs (migratemode cwd) >>= run + +run args + | printhelp args = mapM_ putStrLn usage + | printversion args = putStrLn $ "migrate " ++ showVersion Program.version + | otherwise = migrate args + +bomb msg = + putStrLn msg >> exitFailure + +migrate args = + case (postgres args, mysql args) of + (Nothing, Nothing) -> bomb "Must specify at exactly one of -p or -m for database selection, specified none." + (Just _, Just _) -> bomb "Must specify at exactly one of -p or -m for database selection, specified two." + (Just p, _) -> runpostgres args p + (_, Just m) -> runmysql args m + +runmysql _ _ = + bomb "Not implemented yet." + +runpostgres args connstr = + undefined + +