diff --git a/src/Main.hs b/app/Main.hs similarity index 69% rename from src/Main.hs rename to app/Main.hs index 92a2551..ee5e41f 100644 --- a/src/Main.hs +++ b/app/Main.hs @@ -31,15 +31,17 @@ import Database.PostgreSQL.Simple.Migration (MigrationCommand (..), runMigration) import System.Environment (getArgs) import System.Exit (exitFailure, exitSuccess) +import System.IO (Handle, hPutStrLn, + stdout, stderr) import qualified Data.Text as T import qualified Data.Text.Encoding as T main :: IO () main = getArgs >>= \case - "-h":_ -> - printUsage - "-q":xs -> + x:_ | x `elem` ["-h", "--help"] -> + printUsage stdout + x:xs | x `elem` ["-q", "--quiet"] -> ppException $ run (parseCommand xs) False xs -> ppException $ run (parseCommand xs) True @@ -51,7 +53,7 @@ ppException a = catch a ehandler ehandler e = maybe (throw e) (*> exitFailure) (pSqlError <$> fromException e) bsToString = T.unpack . T.decodeUtf8 - pSqlError e = mapM_ putStrLn + pSqlError e = mapM_ (hPutStrLn stderr) [ "SqlError:" , " sqlState: " , bsToString $ sqlState e @@ -65,8 +67,8 @@ ppException a = catch a ehandler , bsToString $ sqlErrorHint e ] -run :: Maybe Command -> Bool-> IO () -run Nothing _ = printUsage >> exitFailure +run :: Maybe Command -> Bool -> IO () +run Nothing _ = printUsage stderr >> exitFailure run (Just cmd) verbose = handleResult =<< case cmd of Initialize url -> do @@ -91,29 +93,31 @@ 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] " - putStrLn " Options:" - putStrLn " -h Print help text" - putStrLn " -q Enable quiet mode" - putStrLn " Commands:" - putStrLn " init " - putStrLn " Initialize the database. Required to be run" - putStrLn " at least once." - putStrLn " migrate " - 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 " - putStrLn " Validate all SQL scripts in the provided" - putStrLn " directory." - putStrLn " The parameter is based on libpq connection string" - putStrLn " syntax. Detailled information is available here:" - putStrLn " " +printUsage :: Handle -> IO () +printUsage h = do + say "migrate [options] " + say " Options:" + say " -h --help Print help text" + say " -q --quiet Enable quiet mode" + say " Commands:" + say " init " + say " Initialize the database. Required to be run" + say " at least once." + say " migrate " + say " Execute all SQL scripts in the provided" + say " directory in alphabetical order." + say " Scripts that have already been executed are" + say " ignored. If a script was changed since the" + say " time of its last execution, an error is" + say " raised." + say " validate " + say " Validate all SQL scripts in the provided" + say " directory." + say " The parameter is based on libpq connection string" + say " syntax. Detailled information is available here:" + say " " + where + say = hPutStrLn h data Command = Initialize String diff --git a/postgresql-simple-migration.cabal b/postgresql-simple-migration.cabal index f56dafc..cf15eed 100644 --- a/postgresql-simple-migration.cabal +++ b/postgresql-simple-migration.cabal @@ -43,11 +43,13 @@ Library cryptohash >= 0.11 && < 0.12, directory >= 1.2 && < 1.4, postgresql-simple >= 0.4 && < 0.7, - time >= 1.4 && < 1.10 + text >= 1.2 && < 1.3, + time >= 1.4 && < 1.10, + unliftio >= 0.2 && < 0.3 Executable migrate main-is: Main.hs - hs-source-dirs: src + hs-source-dirs: app ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns default-extensions: OverloadedStrings, CPP, LambdaCase default-language: Haskell2010 @@ -58,7 +60,8 @@ Executable migrate directory >= 1.2 && < 1.4, postgresql-simple >= 0.4 && < 0.7, time >= 1.4 && < 1.10, - text >= 1.2 && < 1.3 + text >= 1.2 && < 1.3, + postgresql-simple-migration -any test-suite tests main-is: Main.hs @@ -72,4 +75,5 @@ test-suite tests bytestring >= 0.10 && < 0.11, postgresql-simple >= 0.4 && < 0.7, hspec >= 2.2 && < 2.8, - postgresql-simple-migration + text >= 1.2 && < 1.3, + postgresql-simple-migration -any diff --git a/src/Database/PostgreSQL/Simple/Migration.hs b/src/Database/PostgreSQL/Simple/Migration.hs index cb6ece0..dfe633e 100644 --- a/src/Database/PostgreSQL/Simple/Migration.hs +++ b/src/Database/PostgreSQL/Simple/Migration.hs @@ -12,8 +12,6 @@ -- For usage, see Readme.markdown. {-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} @@ -29,6 +27,7 @@ module Database.PostgreSQL.Simple.Migration -- * Migration types , MigrationContext(..) , MigrationCommand(..) + , MigrationVerbosity(..) , MigrationResult(..) , ScriptName , Checksum @@ -43,13 +42,15 @@ module Database.PostgreSQL.Simple.Migration #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>), (<*>)) #endif -import Control.Monad (void, when) +import Control.Monad (void) +import Control.Monad.IO.Class (MonadIO (liftIO)) import qualified Crypto.Hash.MD5 as MD5 (hash) import qualified Data.ByteString as BS (ByteString, readFile) import qualified Data.ByteString.Base64 as B64 (encode) -import Data.Foldable (Foldable) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Data.String (fromString) import Data.List (isPrefixOf, sort) -import Data.Traversable (Traversable) #if __GLASGOW_HASKELL__ < 710 import Data.Monoid (Monoid (..)) #endif @@ -63,6 +64,7 @@ import Database.PostgreSQL.Simple.ToRow (ToRow (..)) import Database.PostgreSQL.Simple.Types (Query (..)) import Database.PostgreSQL.Simple.Util (existsTable) import System.Directory (getDirectoryContents) +import System.IO (stderr) -- | Executes migrations inside the provided 'MigrationContext'. -- @@ -71,20 +73,23 @@ import System.Directory (getDirectoryContents) -- a 'MigrationError' is returned. -- -- It is recommended to wrap 'runMigration' inside a database transaction. -runMigration :: MigrationContext -> IO (MigrationResult String) -runMigration (MigrationContext cmd verbose con) = case cmd of +runMigration + :: (MonadIO m, MigrationVerbosity verbosity) + => MigrationContext verbosity + -> m (MigrationResult String) +runMigration (MigrationContext cmd verbosity con) = case cmd of MigrationInitialization -> - initializeSchema con verbose >> return MigrationSuccess + initializeSchema con verbosity >> return MigrationSuccess MigrationDirectory path -> - executeDirectoryMigration con verbose path + executeDirectoryMigration con verbosity path MigrationScript name contents -> - executeMigration con verbose name contents + executeMigration con verbosity name contents MigrationFile name path -> - executeMigration con verbose name =<< BS.readFile path + executeMigration con verbosity name =<< liftIO (BS.readFile path) MigrationValidation validationCmd -> - executeValidation con verbose validationCmd + executeValidation con verbosity validationCmd MigrationCommands commands -> - runMigrations verbose con commands + runMigrations verbosity con commands -- | Execute a sequence of migrations -- @@ -94,18 +99,23 @@ runMigration (MigrationContext cmd verbose con) = case cmd of -- -- It is recommended to wrap 'runMigrations' inside a database transaction. runMigrations - :: Bool - -- ^ Run in verbose mode + :: (MonadIO m, MigrationVerbosity verbosity) + => verbosity + -- ^ Verbosity control (e.g. 'Bool') -> Connection -- ^ The postgres connection to use -> [MigrationCommand] -- ^ The commands to run - -> IO (MigrationResult String) -runMigrations verbose con commands = - sequenceMigrations [runMigration (MigrationContext c verbose con) | c <- commands] + -> m (MigrationResult String) +runMigrations verbosity con commands = + sequenceMigrations + [runMigration (MigrationContext c verbosity con) | c <- commands] -- | Run a sequence of contexts, stopping on the first failure -sequenceMigrations :: Monad m => [m (MigrationResult e)] -> m (MigrationResult e) +sequenceMigrations + :: Monad m + => [m (MigrationResult e)] + -> m (MigrationResult e) sequenceMigrations = \case [] -> return MigrationSuccess c:cs -> do @@ -116,47 +126,64 @@ sequenceMigrations = \case -- | Executes all SQL-file based migrations located in the provided 'dir' -- in alphabetical order. -executeDirectoryMigration :: Connection -> Bool -> FilePath -> IO (MigrationResult String) -executeDirectoryMigration con verbose dir = +executeDirectoryMigration + :: (MonadIO m, MigrationVerbosity verbosity) + => Connection + -> verbosity + -> FilePath + -> m (MigrationResult String) +executeDirectoryMigration con verbosity dir = scriptsInDirectory dir >>= go where go fs = sequenceMigrations (executeMigrationFile <$> fs) - executeMigrationFile f = executeMigration con verbose f =<< BS.readFile (dir ++ "/" ++ f) + executeMigrationFile f = + executeMigration con verbosity f + =<< liftIO (BS.readFile $ dir ++ "/" ++ f) -- | Lists all files in the given 'FilePath' 'dir' in alphabetical order. -scriptsInDirectory :: FilePath -> IO [String] +scriptsInDirectory :: MonadIO m => FilePath -> m [String] scriptsInDirectory dir = - fmap (sort . filter (\x -> not $ "." `isPrefixOf` x)) - (getDirectoryContents dir) + sort . filter (\x -> not $ "." `isPrefixOf` x) + <$> liftIO (getDirectoryContents dir) -- | Executes a generic SQL migration for the provided script 'name' with -- content 'contents'. -executeMigration :: Connection -> Bool -> ScriptName -> BS.ByteString -> IO (MigrationResult String) -executeMigration con verbose name contents = do +executeMigration + :: (MonadIO m, MigrationVerbosity verbosity) + => Connection + -> verbosity + -> ScriptName + -> BS.ByteString + -> m (MigrationResult String) +executeMigration con verbosity name contents = do let checksum = md5Hash contents checkScript con name checksum >>= \case ScriptOk -> do - when verbose $ putStrLn $ "Ok:\t" ++ name + migrationLogWrite verbosity $ Right ("Ok:\t" <> fromString name) return MigrationSuccess ScriptNotExecuted -> do - void $ execute_ con (Query contents) - void $ execute con q (name, checksum) - when verbose $ putStrLn $ "Execute:\t" ++ name + void $ liftIO $ execute_ con (Query contents) + void $ liftIO $ execute con q (name, checksum) + migrationLogWrite verbosity $ Left ("Execute:\t" <> fromString name) return MigrationSuccess ScriptModified { actual, expected } -> do - when verbose $ putStrLn - $ "Fail:\t" ++ name - ++ "\n" ++ scriptModifiedErrorMessage expected actual + migrationLogWrite verbosity $ Left + $ "Fail:\t" <> fromString name + <> "\n" <> scriptModifiedErrorMessage expected actual return (MigrationError name) where q = "insert into schema_migrations(filename, checksum) values(?, ?)" -- | Initializes the database schema with a helper table containing -- meta-information about executed migrations. -initializeSchema :: Connection -> Bool -> IO () -initializeSchema con verbose = do - when verbose $ putStrLn "Initializing schema" - void $ execute_ con $ mconcat +initializeSchema + :: (MonadIO m, MigrationVerbosity verbosity) + => Connection + -> verbosity + -> m () +initializeSchema con verbosity = do + migrationLogWrite verbosity $ Right "Initializing schema" + void $ liftIO $ execute_ con $ mconcat [ "create table if not exists schema_migrations " , "( filename varchar(512) not null" , ", checksum varchar(32) not null" @@ -174,9 +201,15 @@ initializeSchema con verbose = do -- * 'MigrationScript': validate the presence and checksum of the given script. -- * 'MigrationFile': validate the presence and checksum of the given file. -- * 'MigrationValidation': always succeeds. --- * 'MigrationCommands': validates all the sub-commands stopping at the first failure. -executeValidation :: Connection -> Bool -> MigrationCommand -> IO (MigrationResult String) -executeValidation con verbose cmd = case cmd of +-- * 'MigrationCommands': validates all the sub-commands stopping at the first +-- failure. +executeValidation + :: (MonadIO m, MigrationVerbosity verbosity) + => Connection + -> verbosity + -> MigrationCommand + -> m (MigrationResult String) +executeValidation con verbosity cmd = case cmd of MigrationInitialization -> existsTable con "schema_migrations" >>= \r -> return $ if r then MigrationSuccess @@ -186,52 +219,59 @@ executeValidation con verbose cmd = case cmd of MigrationScript name contents -> validate name contents MigrationFile name path -> - validate name =<< BS.readFile path + validate name =<< liftIO (BS.readFile path) MigrationValidation _ -> return MigrationSuccess MigrationCommands cs -> - sequenceMigrations (executeValidation con verbose <$> cs) + sequenceMigrations (executeValidation con verbosity <$> cs) where validate name contents = checkScript con name (md5Hash contents) >>= \case ScriptOk -> do - when verbose $ putStrLn $ "Ok:\t" ++ name + migrationLogWrite verbosity $ + Right ("Ok:\t" <> fromString name) return MigrationSuccess ScriptNotExecuted -> do - when verbose $ putStrLn $ "Missing:\t" ++ name + migrationLogWrite verbosity $ + Left ("Missing:\t" <> fromString name) return (MigrationError $ "Missing: " ++ name) ScriptModified { expected, actual } -> do - when verbose $ putStrLn - $ "Checksum mismatch:\t" ++ name - ++ "\n" ++ scriptModifiedErrorMessage expected actual + migrationLogWrite verbosity $ Left + $ "Checksum mismatch:\t" <> fromString name + <> "\n" <> scriptModifiedErrorMessage expected actual return (MigrationError $ "Checksum mismatch: " ++ name) goScripts path xs = sequenceMigrations (goScript path <$> xs) - goScript path x = validate x =<< BS.readFile (path ++ "/" ++ x) + goScript path x = validate x =<< liftIO (BS.readFile $ path ++ "/" ++ x) -- | Checks the status of the script with the given name 'name'. -- If the script has already been executed, the checksum of the script -- is compared against the one that was executed. -- If there is no matching script entry in the database, the script -- will be executed and its meta-information will be recorded. -checkScript :: Connection -> ScriptName -> Checksum -> IO CheckScriptResult +checkScript + :: MonadIO m + => Connection + -> ScriptName + -> Checksum + -> m CheckScriptResult checkScript con name fileChecksum = - query con q (Only name) >>= \case - [] -> - return ScriptNotExecuted - Only dbChecksum:_ | fileChecksum == dbChecksum -> - return ScriptOk - Only dbChecksum:_ -> - return (ScriptModified { - expected = dbChecksum, - actual = fileChecksum - }) + f <$> liftIO (query con q $ Only name) where q = mconcat [ "select checksum from schema_migrations " , "where filename = ? limit 1" ] + f [] = ScriptNotExecuted + f (Only dbChecksum:_) + | fileChecksum == dbChecksum = ScriptOk + | otherwise = + ScriptModified + { expected = dbChecksum + , actual = fileChecksum + } + -- | Calculates the MD5 checksum of the provided bytestring in base64 -- encoding. md5Hash :: BS.ByteString -> Checksum @@ -270,7 +310,8 @@ instance Semigroup MigrationCommand where instance Monoid MigrationCommand where mempty = MigrationCommands [] - mappend (MigrationCommands xs) (MigrationCommands ys) = MigrationCommands (xs ++ ys) + mappend (MigrationCommands xs) (MigrationCommands ys) = + MigrationCommands (xs ++ ys) mappend (MigrationCommands xs) y = MigrationCommands (xs ++ [y]) mappend x (MigrationCommands ys) = MigrationCommands (x : ys) mappend x y = MigrationCommands [x, y] @@ -287,9 +328,10 @@ data CheckScriptResult -- ^ The script has not been executed, yet. This is good. deriving (Show, Eq, Read, Ord) -scriptModifiedErrorMessage :: Checksum -> Checksum -> [Char] +scriptModifiedErrorMessage :: Checksum -> Checksum -> T.Text scriptModifiedErrorMessage expected actual = - "expected: " ++ show expected ++ "\nhash was: " ++ show actual + "expected: " <> fromString (show expected) <> + "\nhash was: " <> fromString (show actual) -- | A sum-type denoting the result of a migration. data MigrationResult a @@ -300,18 +342,19 @@ data MigrationResult a deriving (Show, Eq, Read, Ord, Functor, Foldable, Traversable) -- | The 'MigrationContext' provides an execution context for migrations. -data MigrationContext = MigrationContext +data MigrationContext verbose + = MigrationContext { migrationContextCommand :: MigrationCommand - -- ^ The action that will be performed by 'runMigration' - , migrationContextVerbose :: Bool - -- ^ Verbosity of the library. + -- ^ The action that will be performed by 'runMigration'. + , migrationContextVerbose :: verbose + -- ^ Verbosity of the library (e.g. 'Bool'). , migrationContextConnection :: Connection -- ^ The PostgreSQL connection to use for migrations. } -- | Produces a list of all executed 'SchemaMigration's. -getMigrations :: Connection -> IO [SchemaMigration] -getMigrations = flip query_ q +getMigrations :: MonadIO m => Connection -> m [SchemaMigration] +getMigrations = liftIO . flip query_ q where q = mconcat [ "select filename, checksum, executed_at " , "from schema_migrations order by executed_at asc" @@ -338,3 +381,35 @@ instance FromRow SchemaMigration where instance ToRow SchemaMigration where toRow (SchemaMigration name checksum executedAt) = [toField name, toField checksum, toField executedAt] + +-- | An abstract interface for handling logging. +-- +-- If you need to use a logging framework consider this example: +-- +-- @ +-- data MyLogger = MyLogger Handle +-- +-- instance MigrationVerbosity MyLogger where +-- migrationLogWrite (MyLogger h) = liftIO . T.hPutStrLn h . either id id +-- +-- applyMigration :: Connection -> IO () +-- applyMigration conn = +-- void . runMigration $ +-- MigrationContext MigrationInitialization (MyLogger stderr) conn +-- @ +class MigrationVerbosity verbosity where + migrationLogWrite + :: MonadIO m + => verbosity + -> Either T.Text T.Text + -- ^ Either 'Left' for error log (e.g. stderr) + -- or 'Right' for info log (e.g. stdout) + -> m () + +-- | Default log write implementaion. +-- +-- Either 'False' for quite mode or 'True' for verbose mode. +instance MigrationVerbosity Bool where + migrationLogWrite False _ = pure () + migrationLogWrite True (Left msg) = liftIO $ T.hPutStrLn stderr msg + migrationLogWrite True (Right msg) = liftIO $ T.putStrLn msg diff --git a/src/Database/PostgreSQL/Simple/Util.hs b/src/Database/PostgreSQL/Simple/Util.hs index 66bc1a6..a0d912e 100644 --- a/src/Database/PostgreSQL/Simple/Util.hs +++ b/src/Database/PostgreSQL/Simple/Util.hs @@ -10,7 +10,6 @@ -- A collection of utilites for database migrations. {-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Database.PostgreSQL.Simple.Util @@ -18,15 +17,17 @@ module Database.PostgreSQL.Simple.Util , withTransactionRolledBack ) where -import Control.Exception (finally) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import UnliftIO (MonadUnliftIO) +import UnliftIO.Exception (finally) import Database.PostgreSQL.Simple (Connection, Only (..), begin, query, rollback) import GHC.Int (Int64) -- | Checks if the table with the given name exists in the database. -existsTable :: Connection -> String -> IO Bool +existsTable :: MonadIO m => Connection -> String -> m Bool existsTable con table = - fmap checkRowCount (query con q (Only table) :: IO [[Int64]]) + checkRowCount <$> liftIO (query con q (Only table) :: IO [[Int64]]) where q = "select count(relname) from pg_class where relname = ?" @@ -36,6 +37,6 @@ existsTable con table = -- | Executes the given IO monad inside a transaction and performs a roll-back -- afterwards (even if exceptions occur). -withTransactionRolledBack :: Connection -> IO a -> IO a +withTransactionRolledBack :: MonadUnliftIO m => Connection -> m a -> m a withTransactionRolledBack con f = - begin con >> finally f (rollback con) + liftIO (begin con) >> finally f (liftIO $ rollback con) diff --git a/test/Database/PostgreSQL/Simple/MigrationTest.hs b/test/Database/PostgreSQL/Simple/MigrationTest.hs index 4eabf27..083a63b 100644 --- a/test/Database/PostgreSQL/Simple/MigrationTest.hs +++ b/test/Database/PostgreSQL/Simple/MigrationTest.hs @@ -10,13 +10,16 @@ -- A collection of postgresql-simple-migration specifications. {-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Database.PostgreSQL.Simple.MigrationTest where +import Data.IORef +import Data.Text (Text) +import Control.Monad.IO.Class (liftIO) import Database.PostgreSQL.Simple (Connection) import Database.PostgreSQL.Simple.Migration (MigrationCommand (..), + MigrationVerbosity (..), MigrationContext (..), MigrationResult (..), SchemaMigration (..), @@ -26,7 +29,7 @@ import Database.PostgreSQL.Simple.Util (existsTable) import Test.Hspec (Spec, describe, it, shouldBe) -migrationSpec:: Connection -> Spec +migrationSpec :: Connection -> Spec migrationSpec con = describe "Migrations" $ do let migrationScript = MigrationScript "test.sql" q let migrationScriptAltered = MigrationScript "test.sql" "" @@ -107,6 +110,17 @@ migrationSpec con = describe "Migrations" $ do r <- getMigrations con map schemaMigrationName r `shouldBe` ["test.sql", "1.sql", "s.sql"] + it "log can be redirected" $ do + ref <- newIORef mempty + _ <- runMigration $ MigrationContext + MigrationInitialization (TestLogger ref) con + readIORef ref >>= (`shouldBe` "Initializing schema") + where q = "create table t1 (c1 varchar);" +newtype TestLogger = TestLogger (IORef Text) + +instance MigrationVerbosity TestLogger where + migrationLogWrite (TestLogger ref) = + liftIO . modifyIORef ref . (<>) . either id id diff --git a/test/Main.hs b/test/Main.hs index fbdb7c6..339d87c 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -10,7 +10,6 @@ -- The test entry-point for postgresql-simple-migration. {-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Main