From 923a1010c5894b14505dfca37ef4900ac4084e40 Mon Sep 17 00:00:00 2001 From: Viacheslav Lotsmanov Date: Thu, 1 Oct 2020 05:03:45 +0300 Subject: [PATCH 1/3] Implement log redirection inteface MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit By implementing “runMigrationA” and “runMigrationsA” --- postgresql-simple-migration.cabal | 5 +- src/Database/PostgreSQL/Simple/Migration.hs | 145 +++++++++++++++----- src/Database/PostgreSQL/Simple/Util.hs | 1 - 3 files changed, 111 insertions(+), 40 deletions(-) diff --git a/postgresql-simple-migration.cabal b/postgresql-simple-migration.cabal index f56dafc..24e762e 100644 --- a/postgresql-simple-migration.cabal +++ b/postgresql-simple-migration.cabal @@ -43,11 +43,14 @@ Library cryptohash >= 0.11 && < 0.12, directory >= 1.2 && < 1.4, postgresql-simple >= 0.4 && < 0.7, - time >= 1.4 && < 1.10 + time >= 1.4 && < 1.10, + text >= 1.2 && < 1.3 Executable migrate main-is: Main.hs hs-source-dirs: src + other-modules: Database.PostgreSQL.Simple.Migration + Database.PostgreSQL.Simple.Util ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns default-extensions: OverloadedStrings, CPP, LambdaCase default-language: Haskell2010 diff --git a/src/Database/PostgreSQL/Simple/Migration.hs b/src/Database/PostgreSQL/Simple/Migration.hs index cb6ece0..a074817 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 #-} @@ -23,9 +21,14 @@ module Database.PostgreSQL.Simple.Migration ( -- * Migration actions runMigration + , runMigrationA , runMigrations + , runMigrationsA , sequenceMigrations + -- * Logging + , defaultLogWrite + -- * Migration types , MigrationContext(..) , MigrationCommand(..) @@ -47,6 +50,9 @@ import Control.Monad (void, when) 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 qualified Data.Text as T +import qualified Data.Text.IO as T (putStrLn, hPutStrLn) +import Data.String (fromString) import Data.Foldable (Foldable) import Data.List (isPrefixOf, sort) import Data.Traversable (Traversable) @@ -63,6 +69,10 @@ 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) + +defaultLogWrite :: Either T.Text T.Text -> IO () +defaultLogWrite = either (T.hPutStrLn stderr) T.putStrLn -- | Executes migrations inside the provided 'MigrationContext'. -- @@ -72,19 +82,29 @@ import System.Directory (getDirectoryContents) -- -- It is recommended to wrap 'runMigration' inside a database transaction. runMigration :: MigrationContext -> IO (MigrationResult String) -runMigration (MigrationContext cmd verbose con) = case cmd of +runMigration = runMigrationA defaultLogWrite + +-- | A version of 'runMigration' which gives you control of where the log +-- messages are sent to. +runMigrationA + :: (Either T.Text T.Text -> IO ()) + -- ^ Log write function. 'Either' indicates log level, + -- 'Left' for an error message and 'Right' for an info message. + -> MigrationContext + -> IO (MigrationResult String) +runMigrationA logWrite (MigrationContext cmd verbose con) = case cmd of MigrationInitialization -> - initializeSchema con verbose >> return MigrationSuccess + initializeSchema logWrite con verbose >> return MigrationSuccess MigrationDirectory path -> - executeDirectoryMigration con verbose path + executeDirectoryMigration logWrite con verbose path MigrationScript name contents -> - executeMigration con verbose name contents + executeMigration logWrite con verbose name contents MigrationFile name path -> - executeMigration con verbose name =<< BS.readFile path + executeMigration logWrite con verbose name =<< BS.readFile path MigrationValidation validationCmd -> - executeValidation con verbose validationCmd + executeValidation logWrite con verbose validationCmd MigrationCommands commands -> - runMigrations verbose con commands + runMigrationsA logWrite verbose con commands -- | Execute a sequence of migrations -- @@ -101,11 +121,32 @@ runMigrations -> [MigrationCommand] -- ^ The commands to run -> IO (MigrationResult String) -runMigrations verbose con commands = - sequenceMigrations [runMigration (MigrationContext c verbose con) | c <- commands] +runMigrations = runMigrationsA defaultLogWrite + +-- | A version of 'runMigrations' which gives you control of where the log +-- messages are sent to. +runMigrationsA + :: (Either T.Text T.Text -> IO ()) + -- ^ Log write function. 'Either' indicates log level, + -- 'Left' for an error message and 'Right' for an info message. + -> Bool + -- ^ Run in verbose mode + -> Connection + -- ^ The postgres connection to use + -> [MigrationCommand] + -- ^ The commands to run + -> IO (MigrationResult String) +runMigrationsA logWrite verbose con commands = + sequenceMigrations + [ runMigrationA logWrite (MigrationContext c verbose 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,12 +157,19 @@ 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 + :: LogWrite + -> Connection + -> Bool + -> FilePath + -> IO (MigrationResult String) +executeDirectoryMigration logWrite con verbose dir = scriptsInDirectory dir >>= go where go fs = sequenceMigrations (executeMigrationFile <$> fs) - executeMigrationFile f = executeMigration con verbose f =<< BS.readFile (dir ++ "/" ++ f) + executeMigrationFile f = + BS.readFile (dir ++ "/" ++ f) >>= + executeMigration logWrite con verbose f -- | Lists all files in the given 'FilePath' 'dir' in alphabetical order. scriptsInDirectory :: FilePath -> IO [String] @@ -131,31 +179,37 @@ scriptsInDirectory 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 + :: LogWrite + -> Connection + -> Bool + -> ScriptName + -> BS.ByteString + -> IO (MigrationResult String) +executeMigration logWrite con verbose name contents = do let checksum = md5Hash contents checkScript con name checksum >>= \case ScriptOk -> do - when verbose $ putStrLn $ "Ok:\t" ++ name + when verbose $ logWrite $ 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 + when verbose $ logWrite $ Right $ "Execute:\t" <> fromString name return MigrationSuccess ScriptModified { actual, expected } -> do - when verbose $ putStrLn - $ "Fail:\t" ++ name - ++ "\n" ++ scriptModifiedErrorMessage expected actual + when verbose $ logWrite $ 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" +initializeSchema :: LogWrite -> Connection -> Bool -> IO () +initializeSchema logWrite con verbose = do + when verbose $ logWrite $ Right "Initializing schema" void $ execute_ con $ mconcat [ "create table if not exists schema_migrations " , "( filename varchar(512) not null" @@ -174,9 +228,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 + :: LogWrite + -> Connection + -> Bool + -> MigrationCommand + -> IO (MigrationResult String) +executeValidation logWrite con verbose cmd = case cmd of MigrationInitialization -> existsTable con "schema_migrations" >>= \r -> return $ if r then MigrationSuccess @@ -190,20 +250,21 @@ executeValidation con verbose cmd = case cmd of MigrationValidation _ -> return MigrationSuccess MigrationCommands cs -> - sequenceMigrations (executeValidation con verbose <$> cs) + sequenceMigrations (executeValidation logWrite con verbose <$> cs) where validate name contents = checkScript con name (md5Hash contents) >>= \case ScriptOk -> do - when verbose $ putStrLn $ "Ok:\t" ++ name + when verbose $ logWrite $ Right $ "Ok:\t" <> fromString name return MigrationSuccess ScriptNotExecuted -> do - when verbose $ putStrLn $ "Missing:\t" ++ name + when verbose $ logWrite $ Left $ + "Missing:\t" <> fromString name return (MigrationError $ "Missing: " ++ name) ScriptModified { expected, actual } -> do - when verbose $ putStrLn - $ "Checksum mismatch:\t" ++ name - ++ "\n" ++ scriptModifiedErrorMessage expected actual + when verbose $ logWrite $ Left + $ "Checksum mismatch:\t" <> fromString name + <> "\n" <> scriptModifiedErrorMessage expected actual return (MigrationError $ "Checksum mismatch: " ++ name) goScripts path xs = sequenceMigrations (goScript path <$> xs) @@ -237,6 +298,12 @@ checkScript con name fileChecksum = md5Hash :: BS.ByteString -> Checksum md5Hash = B64.encode . MD5.hash +-- | Log write function. +-- +-- 'Either' indicates log level, +-- 'Left' for an error message and 'Right' for an info message. +type LogWrite = Either T.Text T.Text -> IO () + -- | The checksum type of a migration script. type Checksum = BS.ByteString @@ -270,7 +337,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 +355,10 @@ data CheckScriptResult -- ^ The script has not been executed, yet. This is good. deriving (Show, Eq, Read, Ord) -scriptModifiedErrorMessage :: Checksum -> Checksum -> [Char] -scriptModifiedErrorMessage expected actual = - "expected: " ++ show expected ++ "\nhash was: " ++ show actual +scriptModifiedErrorMessage :: Checksum -> Checksum -> T.Text +scriptModifiedErrorMessage expected actual + = "expected: " <> fromString (show expected) + <> "\nhash was: " <> fromString (show actual) -- | A sum-type denoting the result of a migration. data MigrationResult a diff --git a/src/Database/PostgreSQL/Simple/Util.hs b/src/Database/PostgreSQL/Simple/Util.hs index 66bc1a6..85774d3 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 From 7341a346f2225b1b01f6b137cb71a44041c6fe7a Mon Sep 17 00:00:00 2001 From: Viacheslav Lotsmanov Date: Thu, 1 Oct 2020 05:33:35 +0300 Subject: [PATCH 2/3] =?UTF-8?q?Add=20a=20test=20for=20=E2=80=9CrunMigratio?= =?UTF-8?q?nA=E2=80=9D?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- test/Database/PostgreSQL/Simple/MigrationTest.hs | 12 ++++++++++-- test/Main.hs | 1 - 2 files changed, 10 insertions(+), 3 deletions(-) diff --git a/test/Database/PostgreSQL/Simple/MigrationTest.hs b/test/Database/PostgreSQL/Simple/MigrationTest.hs index 4eabf27..cb346da 100644 --- a/test/Database/PostgreSQL/Simple/MigrationTest.hs +++ b/test/Database/PostgreSQL/Simple/MigrationTest.hs @@ -10,18 +10,19 @@ -- A collection of postgresql-simple-migration specifications. {-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Database.PostgreSQL.Simple.MigrationTest where +import Data.IORef import Database.PostgreSQL.Simple (Connection) import Database.PostgreSQL.Simple.Migration (MigrationCommand (..), MigrationContext (..), MigrationResult (..), SchemaMigration (..), getMigrations, - runMigration) + runMigration, + runMigrationA) import Database.PostgreSQL.Simple.Util (existsTable) import Test.Hspec (Spec, describe, it, shouldBe) @@ -107,6 +108,13 @@ 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 + let logWrite = modifyIORef ref . (<>) . show + _ <- runMigrationA logWrite $ MigrationContext + MigrationInitialization True con + readIORef ref >>= (`shouldBe` "Right \"Initializing schema\"") + where q = "create table t1 (c1 varchar);" 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 From efb45ddfeb7307bfcb04996be9285c9c0a2267fb Mon Sep 17 00:00:00 2001 From: Viacheslav Lotsmanov Date: Thu, 1 Oct 2020 05:37:17 +0300 Subject: [PATCH 3/3] migrate executable: Write to stderr when arguments are incorrect --- src/Main.hs | 58 ++++++++++++++++++++++++++++------------------------- 1 file changed, 31 insertions(+), 27 deletions(-) diff --git a/src/Main.hs b/src/Main.hs index 92a2551..c993888 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -31,6 +31,8 @@ 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 @@ -38,7 +40,7 @@ import qualified Data.Text.Encoding as T main :: IO () main = getArgs >>= \case "-h":_ -> - printUsage + printUsage stdout "-q":xs -> ppException $ run (parseCommand xs) False xs -> @@ -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 Print help text" + say " -q 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