Skip to content
This repository was archived by the owner on Sep 20, 2021. It is now read-only.

Implement log redirection interface #36

Open
wants to merge 3 commits into
base: master
Choose a base branch
from
Open

Implement log redirection interface #36

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
923a101
Implement log redirection inteface
unclechu Oct 1, 2020
7341a34
Add a test for “runMigrationA”
unclechu Oct 1, 2020
efb45dd
migrate executable: Write to stderr when arguments are incorrect
unclechu Oct 1, 2020
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
5 changes: 4 additions & 1 deletion postgresql-simple-migration.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
145 changes: 107 additions & 38 deletions src/Database/PostgreSQL/Simple/Migration.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -12,8 +12,6 @@
-- For usage, see Readme.markdown.

{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
Expand All @@ -23,9 +21,14 @@ module Database.PostgreSQL.Simple.Migration
(
-- * Migration actions
runMigration
, runMigrationA
, runMigrations
, runMigrationsA
, sequenceMigrations

-- * Logging
, defaultLogWrite

-- * Migration types
, MigrationContext(..)
, MigrationCommand(..)
Expand All @@ -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)
Expand All @@ -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'.
--
Expand All @@ -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
--
Expand All @@ -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
Copy link

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I know I said runMigrationsA in the previous review, but this could probably have a more descriptive name? I'm terrible at naming things.

Copy link
Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

@MasseR Ha, I have the same problem. I couldn’t come up with something good. I could name it as runMigrationsWithCustomLogWriteFn but I’m hesitating to add this.

:: (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
Expand All @@ -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)
Copy link

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

It looks like you ran some kind of autoformatter to the source? I don't mind and if were the maintainer I would pass this, but maybe be on the safe side and avoid autoformatters on unfamiliar codebases? Formatting can be a touchy subject for some.

Copy link
Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

No, I didn’t use no formatter. All changes are manual. I realized almost all the lines in the code are limited to 80 chars. But only some aren’t. So I split those lines into few.

Copy link

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I'm still hesitant on it. These kinds of extra changes are just extra noise for the reviewer/maintainer.

Copy link
Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I had to touch this line anyway.

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]
Expand All @@ -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"
Expand All @@ -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
Expand All @@ -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)
Expand Down Expand Up @@ -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

Expand Down Expand Up @@ -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]
Expand All @@ -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
Expand Down
1 change: 0 additions & 1 deletion src/Database/PostgreSQL/Simple/Util.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -10,7 +10,6 @@
-- A collection of utilites for database migrations.

{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

module Database.PostgreSQL.Simple.Util
Expand Down
58 changes: 31 additions & 27 deletions src/Main.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -31,14 +31,16 @@ 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
printUsage stdout
"-q":xs ->
ppException $ run (parseCommand xs) False
xs ->
Expand All @@ -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)
Copy link

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This is a visible change in behavior, I'm hesitant on this. As far as changes go, this is one of the more benign ones, but does change the behavior

postgresql-simple-migration --help | grep foo
postgresql-simple-migration --help | less
postgresql-simple-migration --help 2>&1 | grep foo

Copy link
Author

@unclechu unclechu Oct 2, 2020 •
edited
Loading

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

  1. None of the commands you provided as an example are related to this line in an any way
  2. There’s no such argument --help, I added it to Implement abstract interface for log writes #35 but didn’t in this MR, the command will fail
  3. This will print to stderr only in case there were some errors while applying migrations

If you refer to the usage of printUsage:

  1. If you provide correct -h argument it will, as before, print usage info to stdout thus, if you use the program correctly, it will work as before.
  2. If you provide incorrect arguments the program, as before, will fail and (this changed in this MR) will print usage info to stderr as it should. If you rely somewhere on failure scenario caused by using incorrect arguments then you’re doing something wrong and you’re using the program incorrectly. I think you should not pay any attention to copying bugs in order to keep behavior the same unless you build some platform emulation tool (e.g. WineHQ).
  3. Someone may try to use --help argument (which doesn’t exist), it’s the most default one for getting usage info. But to whom I’m telling this, you just tried to do so in your example! And in Bash, if you don’t use set -eo pipefail, the grepping from your example would succeed (before this change) but this is so only because Bash sucks, it sweeps most of the errors under the carpet by default. It is still a bug. But just for this case I thought it was a good idea to add --help argument alongwith -h one as a part of the MR (which I did in Implement abstract interface for log writes #35 but you were against it, I still think it is a good idea).

[ "SqlError:"
, " sqlState: "
, bsToString $ sqlState e
Expand All @@ -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
Expand All @@ -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] <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>"
printUsage :: Handle -> IO ()
printUsage h = do
say "migrate [options] <command>"
say " Options:"
say " -h Print help text"
say " -q Enable quiet mode"
say " Commands:"
say " init <con>"
say " Initialize the database. Required to be run"
say " at least once."
say " migrate <con> <directory>"
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 <con> <directory>"
say " Validate all SQL scripts in the provided"
say " directory."
say " The <con> parameter is based on libpq connection string"
say " syntax. Detailled information is available here:"
say " <http://www.postgresql.org/docs/9.3/static/libpq-connect.html>"
where
say = hPutStrLn h

data Command
= Initialize String
Expand Down
Loading