database-migrate 0.0.3 → 0.1.0

raw patch · 8 files changed

+312/−164 lines, 8 filesdep ~bytestringdep ~cmdargsdep ~containersPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: bytestring, cmdargs, containers, directory, either, filepath, text, time, transformers

API changes (from Hackage documentation)

Files

• database-migrate.cabal +15/−17
• src/Database/Migrate.hs +3/−4
• src/Database/Migrate/Core.hs +0/−85
• src/Database/Migrate/Data.hs +73/−0
• src/Database/Migrate/Kernel.hs +52/−0
• src/Database/Migrate/Loader.hs +35/−0
• src/Database/Migrate/Main.hs +102/−53
• src/Database/Migrate/PostgreSQL.hs +32/−5

@@ -1,11 +1,11 @@ Name:               database-migrate-Version:            0.0.3+Version:            0.1.0 License:            BSD3 License-File:       LICENSE Author:             Mark Hibberd <mark@hibberd.id.au> Maintainer:         Mark Hibberd <mark@hibberd.id.au> Copyright:          (c) 2012 Mark Hibberd-Synopsis:           Database versioning and migration+Synopsis:           Database versioning and migration (experimental) Category:           Database Homepage:           https://github.com/markhibberd/database-migrate Bug-reports:           https://github.com/markhibberd/database-migrate/issues@@ -29,17 +29,17 @@  Library   Build-Depends:-                    base                            >= 3          && < 5-                    , text                          >= 0.11       && < 0.12-                    , directory                     >= 1.0        && < 2.0-                    , filepath                      >= 1.0        && < 2.0-                    , bytestring                    >= 0.9        && < 0.10-                    , time                          >= 1.0        && < 2.0+                    base                            >= 3 && < 5+                    , text                          >= 0.11+                    , directory                     >= 1.0+                    , filepath                      >= 1.0+                    , bytestring                    >= 0.9+                    , time                          >= 1.0                     , postgresql-simple             == 0.1.4.3-                    , containers                    >= 0.4        && < 0.5-                    , either                        >= 3.0.2      && < 4.0-                    , transformers                  >= 0.2        && < 0.4-                    , cmdargs                       >= 0.9.3      && < 1.0.0+                    , containers                    >= 0.4+                    , either                        >= 3.0.2+                    , transformers                  >= 0.2+                    , cmdargs                       >= 0.9.3    GHC-Options:                     -Wall -fno-warn-orphans@@ -49,10 +49,8 @@    Exposed-Modules:                     Database.Migrate+                    Database.Migrate.Data+                    Database.Migrate.Kernel+                    Database.Migrate.Loader                     Database.Migrate.Main-                    Database.Migrate.Core                     Database.Migrate.PostgreSQL--  Extensions:-                    MultiParamTypeClasses-                    OverloadedStrings

@@ -16,9 +16,8 @@ -- module Database.Migrate (module X) where +import Database.Migrate.Data as X+import Database.Migrate.Kernel as X+import Database.Migrate.Loader as X import Database.Migrate.Main as X-import Database.Migrate.Core as X--- import Database.Migrate.MySQL as X import Database.Migrate.PostgreSQL as X--

@@ -1,85 +0,0 @@-{-#LANGUAGE OverloadedStrings, ScopedTypeVariables#-}-module Database.Migrate.Core where--import Control.Monad-import Control.Monad.IO.Class-import Control.Monad.Trans.Class-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--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 =-  Migration {-      migration :: MigrationId-    , up :: Text-    , 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-  , msg :: Text-  , rolledback :: Bool-  } deriving (Eq, Show)--type MigrationResultT = EitherT Context--class Monad m => MigrateDatabase m c where-  initialize :: c -> m ()-  runMigrations :: c -> (Migration -> Ddl) -> [Migration] -> MigrationResultT m [MigrationId]-  getMigrations :: c -> m [MigrationId]--pick :: [Migration] -> [MigrationId] -> [Migration]-pick ms ids =-  let available = foldr (S.insert . migration) S.empty ms-      installed = S.fromList ids-      torun = S.difference available installed-   in filter (\m -> S.member (migration m) torun) ms--latest :: MigrateDatabase m c => c -> [Migration] -> MigrationResultT m [MigrationId]-latest c migrations =-  lift (getMigrations c) >>= \installed -> runMigrations c up (pick migrations installed)--find :: FilePath -> EitherT String IO [Migration]-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 (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 . fmap dropExtensions)-      (filter (\p -> takeExtensions p == ".up.sql") files))--readFile' :: FilePath -> IO String-readFile' p = withFile p ReadMode hGetContents--hGetContents' :: Handle -> IO String-hGetContents' h = hGetContents h >>= \s -> length s `seq` return s-

@@ -0,0 +1,73 @@+{-#LANGUAGE RankNTypes, ScopedTypeVariables #-}+module Database.Migrate.Data where++import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Writer+import Control.Monad.Trans.Maybe++import Data.Text hiding (foldr, filter, reverse, length)++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)++data MigrationLog =+    DatabaseInitialized+  | MigrationApplied Migration+  | MigrationFailed Migration String+  | MigrationRolledback Migration String+  deriving (Eq, Show)++data Migration =+  Migration {+      migrationId :: MigrationId+    , up :: Text+    , down :: Text+    } deriving (Eq, Show)++instance Ord Migration where+  compare a b = compare (migrationId a) (migrationId b)++data MigrationRecords =+    NotInitialized+  | Initialized [MigrationId]++-- FIX should not be a list, want to index and sort migrations+data Migrations =+  Migrations { getMigrations :: [Migration] }++data Migrate c m a =+  Migrate { runMigrate :: ReaderT (Migrations, c) (MaybeT (WriterT [MigrationLog] m)) a }++-- FIX consider adding history+-- FIX add reverse engineer to extract current schema+data MigrateDatabase m c =+  MigrateDatabase {+      current :: Migrate c m MigrationRecords+    , initialize :: Migrate c m ()+    , runSql :: Text -> Migrate c m ()+    , recordInstall :: Migration -> Migrate c m ()+    , recordRollback :: Migration -> Migrate c m ()+    }++instance Monad f => Functor (Migrate c f) where+  fmap f a = a >>= \a' -> return (f a')++instance Monad m => Monad (Migrate c m) where+  return a = Migrate $ return a+  m >>= f = Migrate $ do+    a <- runMigrate m+    runMigrate (f a)++instance MonadTrans (Migrate c) where+  lift = Migrate . lift . lift . lift++instance MonadIO m => MonadIO (Migrate c m) where+  liftIO = lift . liftIO

@@ -0,0 +1,52 @@+{-#LANGUAGE RankNTypes, ScopedTypeVariables #-}+module Database.Migrate.Kernel where++import Database.Migrate.Data++import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Writer++import qualified Data.Set as S+import Data.Functor++mlog :: Monad m => MigrationLog -> Migrate c m ()+mlog l = Migrate . lift . lift $ tell [l]++connection :: (Functor m, Monad m) => Migrate c m c+connection = Migrate $ fmap snd ask++store :: (Functor m, Monad m) => Migrate c m Migrations+store = Migrate $ fmap fst ask++dryrun :: Monad m => MigrateDatabase m c -> MigrateDatabase m c+dryrun db =+  MigrateDatabase {+      current = current db+    , initialize = return ()+    , runSql = \_ -> return ()+    , recordInstall = \_ -> return ()+    , recordRollback = \_ -> return ()+    }++migrate :: (Functor m, Monad m) => MigrateDatabase m c -> Migrate c m ()+migrate db =+  do records <- current db+     ms <- store+     migrations <- case records of+       NotInitialized -> getMigrations ms <$ (mlog DatabaseInitialized >> initialize db)+       Initialized mids -> return $ missing ms mids+     forM_ migrations (\m -> mlog (MigrationApplied m) >> (runSql db (up m) >> recordInstall db m))++missing :: Migrations -> [MigrationId] -> [Migration]+missing ms applied =+  let migrations = getMigrations ms+      available = foldr (S.insert . migrationId) S.empty migrations+      installed = S.fromList applied+      torun = S.difference available installed+   in filter (\m -> S.member (migrationId m) torun) migrations++executeMigrate :: Monad m => Migrations -> c -> Migrate c m a -> m (Maybe a, [MigrationLog])+executeMigrate = \ms c m -> runWriterT (runMaybeT (runReaderT (runMigrate m) (ms, c)))

@@ -0,0 +1,35 @@+module Database.Migrate.Loader where++import Database.Migrate.Data++import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Either++import Data.List (sort)+import Data.Text hiding (filter, length)++import System.FilePath+import System.Directory+import System.IO++find :: FilePath -> EitherT String IO Migrations+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 (MigrationId . pack $ p) (pack u) (pack d) ))) >>= \ms -> return $ Migrations ms++migrationids :: FilePath -> [FilePath] -> IO [String]+migrationids b ps =+  filterM (\p -> doesFileExist (b </> p)) ps >>= \files ->+    ((return . fmap dropExtensions)+      (filter (\p -> takeExtensions p == ".up.sql") files))++readFile' :: FilePath -> IO String+readFile' p = withFile p ReadMode hGetContents++hGetContents' :: Handle -> IO String+hGetContents' h = hGetContents h >>= \s -> length s `seq` return s

@@ -1,79 +1,128 @@+{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-}-module Database.Migrate.Main (defaultMain) where+module Database.Migrate.Main (defaultMain, defaultMain') where ---import qualified Paths_database_migrate as Program (version)+import qualified Paths_database_migrate as Program (version) +import Control.Monad+import Control.Monad.Trans.Either+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Writer+import Control.Monad.Trans.Maybe+ import qualified Data.Text as T+import Data.Maybe import Data.Version (showVersion) -import Database.PostgreSQL.Simple+import Database.Migrate.Data+import Database.Migrate.Kernel+import Database.Migrate.Loader+import Database.Migrate.PostgreSQL +import qualified Database.PostgreSQL.Simple as PG+ import System.Console.CmdArgs.Explicit import System.Directory+import System.FilePath import System.Exit+import System.Environment (getArgs)+import System.IO +ignore :: Arg Arguments+ignore = flagArg (\_ a -> Right a) ""++e :: String+e = ""+ 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"+    "usage: db migrate [-v|--verbose] [-d|--dry-run]"+  , "       db up [-v|--verbose] [-d|--dry-run]"+  , "       db down [-v|--verbose] [-d|--dry-run]"+  , "       db apply [-v|--verbose] [-d|--dry-run]"+  , "       db -h|--help"+  , "       db -V|--version"   ] ++globalflags :: [Flag Arguments]+globalflags = [+    flagNone [ "h", "help" ]     (\a -> a { adbmode = HelpMode })    e+  , flagNone [ "V", "version" ]  (\a -> a { adbmode = VersionMode }) e+  ]++connectflags :: [Flag Arguments]+connectflags = [+    flagNone [ "v", "verbose" ]    (\a -> a { averbose = True }) e+  , flagNone [ "d", "dry-run" ]    (\a -> a { adry = True }) e+  ]++versionflag = (flagArg (\v a -> Right $ a { aversion = Just v }) "VERSION")++cmdmodes :: String -> Arguments -> Mode Arguments+cmdmodes cmd initial =+  modes cmd initial "" [+      mode "migrate" (initial { adbmode = MigrateMode }) "" ignore connectflags+    , mode "up" (initial { adbmode = UpMode }) "" versionflag connectflags+    , mode "down" (initial { adbmode = DownMode }) "" versionflag connectflags+    , mode "apply" (initial { adbmode = ApplyMode }) "" versionflag connectflags+    , mode "help" (initial { adbmode = HelpMode }) "" ignore []+    , mode "version" (initial { adbmode = VersionMode }) "" ignore []+    ]++data DbMode =+    HelpMode+  | VersionMode+  | MigrateMode+  | UpMode+  | DownMode+  | ApplyMode+  deriving (Eq, Show)+ data Arguments = Arguments {-    printhelp :: Bool-  , printversion :: Bool-  , dry :: Bool-  , test :: Bool-  , auto :: Bool-  , postgres :: Bool-  , mysql :: Bool-  , version :: Maybe String-  , scripts :: String+    adbmode :: DbMode+  , adry :: Bool+  , averbose :: Bool+  , ascripts :: String+  , aversion :: Maybe 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+    adbmode = HelpMode+  , adry = False+  , averbose = False+  , ascripts = cwd </> "migrations"+  , aversion = Nothing   } -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+defaultMain :: Migrations -> MigrateDatabase IO c -> IO c -> IO ()+defaultMain migrationstore db connector = getArgs >>= defaultMain' migrationstore db connector -run args-  | printhelp args      = mapM_ putStrLn usage-  | printversion args   = putStrLn $ "migrate " ++ "showVersion Program.version"-  | otherwise           = migrate args+defaultMain' :: Migrations -> MigrateDatabase IO c -> IO c -> [String] -> IO ()+defaultMain' migrationstore db connector args =+  getCurrentDirectory >>= \cwd ->+    case process ((cmdmodes "migrate" (defaultArguments cwd)) {modeGroupFlags = toGroup $ globalflags} ) args of+      Left x ->  hPutStrLn stderr x >> exitFailure+      Right x -> run migrationstore db connector x -bomb msg =-  putStrLn msg >> exitFailure+run :: Migrations -> MigrateDatabase IO c -> IO c -> Arguments -> IO ()+run migrationstore db' connector args =+  let db = if adry args then dryrun db' else db'+  in case adbmode args of+    HelpMode -> mapM_ putStrLn usage+    VersionMode -> putStrLn $ "migrate " ++ showVersion Program.version+    MigrateMode -> connector  >>= \c -> (executeMigrate migrationstore c $ migrate db) >>= print+    UpMode -> connector >>= \c -> (executeMigrate migrationstore c $ upmode db) >>= print+    DownMode -> connector >>= \c -> (executeMigrate migrationstore c $ downmode db) >>= print+    ApplyMode -> connector >>= \c -> (executeMigrate migrationstore c $ applymode db) >>= print -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+bomb failwith =+  putStrLn failwith >> exitFailure -runmysql _  =-  bomb "Not implemented yet."+upmode :: MigrateDatabase m c -> Migrate c m ()+upmode = undefined -runpostgres args =-  undefined+downmode :: MigrateDatabase m c -> Migrate c m ()+downmode = undefined +applymode :: MigrateDatabase m c -> Migrate c m ()+applymode = undefined

@@ -1,18 +1,20 @@ {-#LANGUAGE OverloadedStrings #-} module Database.Migrate.PostgreSQL where +import Database.Migrate.Data+import Database.Migrate.Kernel+ import Control.Exception (SomeException(..), handle) import Control.Monad import Control.Monad.IO.Class-import Control.Monad.Trans.Either +import Data.Maybe 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@@ -20,9 +22,33 @@ 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+data PsqlConnectInfo = PsqlConnectInfo++psqlMigrateDatabase :: MigrateDatabase IO Connection+psqlMigrateDatabase =+  MigrateDatabase {+    current = connection >>= \c ->+     liftIO (query_ c "SELECT TRUE FROM pg_tables WHERE schemaname='public' AND tablename = 'migration_info'") >>= \r ->+      return (maybe False fromOnly (listToMaybe r)) >>= \rr ->+      if rr+        then liftIO (fmap Initialized (fmap (fmap fromOnly) (query_ c "SELECT migration FROM migration_info")))+        else return NotInitialized+  , initialize = connection >>= \c -> liftIO . void $+      execute_ c "CREATE TABLE IF NOT EXISTS migration_info (migration VARCHAR(50) PRIMARY KEY)"+  , runSql = \sql -> connection >>= \c ->+     liftIO . void $ execute_ c (fromString . unpack $ sql)+  , recordInstall = \m -> connection >>= \c ->+     liftIO . void $ (begin c >> execute c "INSERT INTO migration_info (migration) VALUES (?)" (Only $ migrationId m) >> commit c)+  , recordRollback = \m -> connection >>= \c ->+     liftIO . void $ (begin c >> execute c "DELETE FROM migration_info WHERE migration = ?" (Only $ migrationId m) >> commit c)+  }++{-+  testconn =  connection >>= \c ->  query_ c "SELECT TRUE" >>= \r -> return $ maybe False fromOnly (listToMaybe r)++  initialize = connection >>= \c -> void $ execute_ c "CREATE TABLE IF NOT EXISTS MIGRATION_INFO (MIGRATION VARCHAR(50) PRIMARY KEY)"+  initialized = connection >>= \c -> query_ c "SELECT TRUE FROM pg_tables WHERE schemaname='public' AND tablename = MIGRATION_INFO" >>= \r -> return $ maybe False fromOnly (listToMaybe r)+  runMigration = runall   getMigrations c = fmap (fmap fromOnly) (query_ c "SELECT MIGRATION FROM MIGRATION_INFO")  @@ -61,3 +87,4 @@  run :: Connection -> (Migration -> Ddl) -> Migration -> IO MigrationId run c f m = execute_ c (fromString . unpack $ f m) >> record c (migration m) >> return (migration m)+-}