-- |
-- Module : Main
-- Copyright : (c) 2014 Andreas Meingast <ameingast@gmail.com>
--
-- License : BSD-style
-- Maintainer : andre@andrevdm.com
-- Stability : experimental
-- Portability : GHC
--
-- A standalone program for the postgresql-migration library.
{-# LANGUAGE OverloadedStrings #-}
module Main
( main
) where
import Control.Exception
import Control.Monad (when)
import qualified Data.ByteString as BS (ByteString)
import qualified Data.ByteString.Char8 as BS8 (pack)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Database.PostgreSQL.Simple ( SqlError (..)
, connectPostgreSQL
)
import Database.PostgreSQL.Simple.Migration ( MigrationCommand (..)
, MigrationOptions (..)
, MigrationResult (..)
, TransactionControl (..)
, Verbosity (..)
, defaultOptions
, runMigration
)
import Data.Version (showVersion)
import System.Environment (getArgs)
import System.Exit (exitFailure, exitSuccess)
import System.IO (Handle, hPutStrLn, stdout, stderr)
import qualified Paths_postgresql_migration as P
main :: IO ()
main = do
args <- getArgs
case collectArgs args (Verbose, TransactionPerRun) of
ArgPrintUsage -> printUsage stdout
ArgCommand (verbose, trn, rest) -> ppException $ run (parseCommand rest) verbose trn
data ArgAction
= ArgPrintUsage
| ArgCommand (Verbosity, TransactionControl, [[Char]])
collectArgs :: [[Char]] -> (Verbosity, TransactionControl) -> ArgAction
collectArgs [] (v, t) = ArgCommand (v, t, [])
collectArgs (x:xs) (v, t) =
case x of
"-h" -> ArgPrintUsage
"-q" -> collectArgs xs (Quiet, t)
"-t" -> collectArgs xs (v, TransactionPerStep)
_ -> ArgCommand (v, t, x:xs)
-- | Pretty print postgresql-simple exceptions to see whats going on
ppException :: IO a -> IO a
ppException a = catch a ehandler
where
ehandler e = maybe (throw e) (*> exitFailure) (pSqlError <$> fromException e)
bsToString = T.unpack . T.decodeUtf8
pSqlError e = mapM_ (hPutStrLn stderr)
[ "SqlError:"
, " sqlState: ", bsToString $ sqlState e
, " sqlExecStatus: ", show $ sqlExecStatus e
, " sqlErrorMsg: ", bsToString $ sqlErrorMsg e
, " sqlErrorDetail: ", bsToString $ sqlErrorDetail e
, " sqlErrorHint: ", bsToString $ sqlErrorHint e
]
run
:: Maybe Command
-> Verbosity
-> TransactionControl
-> IO ()
run Nothing _ _ = printUsage stderr >> exitFailure
run (Just cmd) verbose trnControl = do
when (verbose == Verbose) $ do
putStrLn $ "postgresql-migration Version: " <> showVersion P.version
putStrLn $ "Verbosity: " <> show verbose
putStrLn $ "Transactions: " <> show trnControl
handleResult =<< case cmd of
Initialize url tableName -> do
con <- connectPostgreSQL (BS8.pack url)
let opts = defaultOptions
{ optTableName = tableName
, optVerbose = verbose
, optTransactionControl = trnControl
}
runMigration con opts MigrationInitialization
Migrate url dir tableName -> do
con <- connectPostgreSQL (BS8.pack url)
let opts = defaultOptions
{ optTableName = tableName
, optVerbose = verbose
, optTransactionControl = trnControl
}
runMigration con opts $ MigrationDirectory dir
Validate url dir tableName -> do
con <- connectPostgreSQL $ BS8.pack url
let opts = defaultOptions
{ optTableName = tableName
, optVerbose = verbose
, optTransactionControl = trnControl
}
runMigration con opts $ MigrationValidation (MigrationDirectory dir)
where
handleResult MigrationSuccess = exitSuccess
handleResult (MigrationError _) = exitFailure
parseCommand :: [String] -> Maybe Command
parseCommand ("init":url:tableName:_) = Just (Initialize url (BS8.pack tableName))
parseCommand ("migrate":url:dir:tableName:_) = Just (Migrate url dir (BS8.pack tableName))
parseCommand ("validate":url:dir:tableName:_) = Just (Validate url dir (BS8.pack tableName))
parseCommand ("init":url:_) = Just (Initialize url "schema_migrations")
parseCommand ("migrate":url:dir:_) = Just (Migrate url dir "schema_migrations")
parseCommand ("validate":url:dir:_) = Just (Validate url dir "schema_migrations")
parseCommand _ = Nothing
printUsage :: Handle -> IO ()
printUsage h = do
hPutStrLn h "migrate [options] <command>"
hPutStrLn h " Options:"
hPutStrLn h " -h Print help text"
hPutStrLn h " -q Enable quiet mode"
hPutStrLn h " -t Enable transaction per script"
hPutStrLn h " defauts to a single transaction for the entire migration(s)"
hPutStrLn h " Commands:"
hPutStrLn h " init <con> {migrations table name}"
hPutStrLn h " Initialize the database. Required to be run"
hPutStrLn h " at least once."
hPutStrLn h " {migrations table name} is the optiona name."
hPutStrLn h " for the migrations table. This defaults to"
hPutStrLn h " `schema_migrations`."
hPutStrLn h " migrate <con> <directory> {migrations table name}"
hPutStrLn h " Execute all SQL scripts in the provided"
hPutStrLn h " directory in alphabetical order."
hPutStrLn h " Scripts that have already been executed are"
hPutStrLn h " ignored. If a script was changed since the"
hPutStrLn h " time of its last execution, an error is"
hPutStrLn h " raised."
hPutStrLn h " {migrations table name} is the optiona name."
hPutStrLn h " for the migrations table. This defaults to"
hPutStrLn h " `schema_migrations`."
hPutStrLn h " validate <con> <directory> {migrations table name}"
hPutStrLn h " Validate all SQL scripts in the provided"
hPutStrLn h " directory."
hPutStrLn h " {migrations table name} is the optiona name."
hPutStrLn h " for the migrations table. This defaults to"
hPutStrLn h " `schema_migrations`."
hPutStrLn h " The <con> parameter is based on libpq connection string"
hPutStrLn h " syntax. Detailled information is available here:"
hPutStrLn h " <http://www.postgresql.org/docs/9.3/static/libpq-connect.html>"
data Command
= Initialize String BS.ByteString
| Migrate String FilePath BS.ByteString
| Validate String FilePath BS.ByteString