-- |
-- Module : Main
-- Copyright : (c) 2014 Andreas Meingast <ameingast@gmail.com>
--
-- License : BSD-style
-- Maintainer : ameingast@gmail.com
-- Stability : experimental
-- Portability : GHC
--
-- A standalone program for the postgresql-simple-migration library.
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Main (
main
) where
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif
import Control.Exception
import Control.Monad (void)
import qualified Data.ByteString.Char8 as BS8 (pack)
import Database.PostgreSQL.Simple (SqlError (..),
connectPostgreSQL,
withTransaction)
import Database.PostgreSQL.Simple.Migration (MigrationCommand (..),
MigrationContext (..),
runMigration)
import System.Environment (getArgs)
import System.Exit (exitFailure)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
main :: IO ()
main = getArgs >>= \args -> case args of
"-h":_ ->
printUsage
"-q":xs ->
ppException $ run (parseCommand xs) False
xs ->
ppException $ run (parseCommand xs) True
-- | 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)
-- <|> (pOtherError <$> fromException e)
bsToString = T.unpack . T.decodeUtf8
pSqlError e = mapM_ putStrLn
[ "SqlError:"
, " sqlState: "
, bsToString $ sqlState e
, " sqlExecStatus: "
, show $ sqlExecStatus e
, " sqlErrorMsg: "
, bsToString $ sqlErrorMsg e
, " sqlErrorDetail: "
, bsToString $ sqlErrorDetail e
, " sqlErrorHint: "
, bsToString $ sqlErrorHint e
]
run :: Maybe Command -> Bool-> IO ()
run Nothing _ = printUsage >> exitFailure
run (Just cmd) verbose =
void $ case cmd of
Initialize url -> do
con <- connectPostgreSQL (BS8.pack url)
withTransaction con $ runMigration $ MigrationContext
MigrationInitialization verbose con
Migrate url dir -> do
con <- connectPostgreSQL (BS8.pack url)
withTransaction con $ runMigration $ MigrationContext
(MigrationDirectory dir) verbose con
Validate url dir -> do
con <- connectPostgreSQL (BS8.pack url)
withTransaction con $ runMigration $ MigrationContext
(MigrationValidation (MigrationDirectory dir)) verbose con
parseCommand :: [String] -> Maybe Command
parseCommand ("init":url:_) = Just (Initialize url)
parseCommand ("migrate":url:dir:_) = Just (Migrate url dir)
parseCommand ("validate":url:dir:_) = Just (Validate url dir)
parseCommand _ = Nothing
printUsage :: IO ()
printUsage = do
putStrLn "migrate [options] <command>"
putStrLn " Options:"
putStrLn " -h Print help text"
putStrLn " -q Enable quiet mode"
putStrLn " Commands:"
putStrLn " init <con>"
putStrLn " Initialize the database. Required to be run"
putStrLn " at least once."
putStrLn " migrate <con> <directory>"
putStrLn " Execute all SQL scripts in the provided"
putStrLn " directory in alphabetical order."
putStrLn " Scripts that have already been executed are"
putStrLn " ignored. If a script was changed since the"
putStrLn " time of its last execution, an error is"
putStrLn " raised."
putStrLn " validate <con> <directory>"
putStrLn " Validate all SQL scripts in the provided"
putStrLn " directory."
putStrLn " The <con> parameter is based on libpq connection string"
putStrLn " syntax. Detailled information is available here:"
putStrLn " <http://www.postgresql.org/docs/9.3/static/libpq-connect.html>"
data Command
= Initialize String
| Migrate String FilePath
| Validate String FilePath
deriving (Show, Eq, Read, Ord)