database-migrate 0.0.1 → 0.0.2

raw patch · 6 files changed

+230/−20 lines, 6 filesdep +cmdargsdep +database-migratenew-component:exe:migratePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: cmdargs, database-migrate

API changes (from Hackage documentation)

Files

• database-migrate.cabal +19/−6
• src/Database/Migrate.hs +8/−5
• src/Database/Migrate/Core.hs +19/−6
• src/Database/Migrate/Main.hs +78/−0
• src/Database/Migrate/PostgreSQL.hs +29/−3
• src/main.hs +77/−0

@@ -1,5 +1,5 @@ Name:               database-migrate-Version:            0.0.1+Version:            0.0.2 License:            BSD3 License-File:       LICENSE Author:             Mark Hibberd <mark@hibberd.id.au>@@ -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

@@ -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+ 

@@ -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

@@ -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+

@@ -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)

@@ -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++