Skip to content

Commit

Permalink
Show and register migration application time (#180)
Browse files Browse the repository at this point in the history 
* Create Codd Schema version type and update internal schema accordingly

Also, there are fewer code branches in internal migration application code.
This is better because otherwise we'd have to add additional "detect codd
schema >> create or update schema" code to at least one of the removed
branches.

It feels more sustainable to get rid of the additional branches altogether.

* Fill the new application_duration columns

* Reuse `registerRanMigration` internally

* Test application durations are registered

* Test that all codd_schema version migrations do not crash

* Pretty printing durations, fixing DiffTime -> NominalDiffTime conversion

This also makes `codd add` verbose by default, which seems more reasonable?
Not sure.

* Add color to output when the terminal supports it

* Use codd logger in tests too

* Float color support value out. Add some comments

* Fine-tune colors and codd's output

* Replace monad-logger with our own custom monad

Reasons explained in Logging.hs

* Remove `Verbosity` type

* Beta-reduce `Newline` argument

* Use function names that differ from monad-logger's to avoid confusion

* Fix a silly mistake with colors. Improve one message.

* Rename `MonadLogger` to `CoddLogger` to avoid confusion

* Update codd's output in README
  • Loading branch information
@mzabani
mzabani authored Mar 5, 2024
1 parent 7fe8da5 commit fb5a4b1
Show file tree
Hide file tree
Showing 24 changed files with 689 additions and 480 deletions.
24 changes: 12 additions & 12 deletions README.md
View file
Original file line number Diff line number Diff line change
Expand Up @@ -23,8 +23,9 @@ Here you can see its main features in more detail:
$ cat create-animals-table.sql
CREATE TABLE animals (id SERIAL PRIMARY KEY, popular_name TEXT NOT NULL);
INSERT INTO animals (popular_name) VALUES ('Dog'), ('Cat');
$ codd add create-animals-table.sql
Migration applied and added to sql-migrations/2022-02-27-23-14-50-create-animals-table.sql
$ codd add --quiet create-animals-table.sql
New migration applied and added to sql-migrations/all/2024-03-05-19-27-43-create-animals-table.sql
Updated expected DB schema representations in the expected-schema folder
$ psql -c "SELECT popular_name FROM animals"
popular_name
--------------
Expand All @@ -44,7 +45,7 @@ $ psql -c "SELECT popular_name FROM animals"
$ psql -c "ALTER TABLE animals ALTER COLUMN popular_name TYPE VARCHAR(30)"
ALTER TABLE
$ codd verify-schema
[Error] DB and expected schemas do not match. Differing objects and their current DB schemas are: {"schemas/public/tables/animals/cols/popular_name":["different-schemas",{"collation":"default","collation_nsp":"pg_catalog","default":null,"generated":"","hasdefault":false,"identity":"","inhcount":0,"local":true,"notnull":true,"order":2,"privileges":null,"type":"varchar"}]}
Error: DB and expected schemas do not match. Differing objects and their current DB schemas are: {"schemas/public/tables/animals/cols/popular_name":["different-schemas",{"collation":"default","collation_nsp":"pg_catalog","default":null,"generated":"","hasdefault":false,"identity":"","inhcount":0,"local":true,"notnull":true,"order":2,"privileges":null,"type":"varchar","typmod":34}]}
````

</td>
Expand All @@ -56,15 +57,14 @@ $ codd verify-schema

````shell
$ codd up
[Info] Checking if database 'codd-experiments' is accessible with the configured connection string... (waiting up to 5sec)
[Info] Checking which SQL migrations have already been applied...
[Info] Parse-checking headers of all pending SQL Migrations...
[Info] BEGINning transaction
[Info] Applying 2022-02-27-23-14-50-create-animals-table.sql
[Info] Applying 2022-02-27-23-30-41-create-people-table.sql
[Info] Database and expected schemas match.
[Info] COMMITed transaction
[Info] All migrations applied to codd-experiments successfully
Checking if database codd-experiments is accessible with the configured connection string... (waiting up to 5sec)
Looking for pending migrations... [2 found]
BEGINning transaction
Applying 2022-02-27-23-14-50-create-animals-table.sql (0.08ms)
Applying 2022-02-27-23-30-41-create-people-table.sql (0.13ms)
Comparing actual and expected schemas... [match]
COMMITed transaction
Successfully applied all migrations to codd-experiments
````

</td>
Expand Down
35 changes: 13 additions & 22 deletions app/Main.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -10,12 +10,12 @@ import Codd.AppCommands.WriteSchema ( WriteSchemaOpts(..)
)
import Codd.Environment ( CoddSettings(..) )
import qualified Codd.Environment as Codd
import Codd.Logging ( Verbosity(..)
, runVerbosityLogger
import Codd.Logging ( LogLevel(..)
, runCoddLogger
, runCoddLoggerLevelFilter
)
import Codd.Types ( SqlFilePath(..) )
import Control.Monad ( void )
import Control.Monad.Logger ( runStdoutLoggingT )
import Data.Functor ( (<&>) )
import qualified Data.List as List
import Data.String ( IsString )
Expand All @@ -24,7 +24,7 @@ import Options.Applicative
import qualified System.IO as IO
import qualified Text.Read as Text

data Cmd = Up (Maybe Codd.VerifySchemas) DiffTime | Add AddMigrationOptions (Maybe FilePath) Verbosity SqlFilePath | WriteSchema WriteSchemaOpts | VerifySchema Verbosity Bool
data Cmd = Up (Maybe Codd.VerifySchemas) DiffTime | Add AddMigrationOptions (Maybe FilePath) (LogLevel -> Bool) SqlFilePath | WriteSchema WriteSchemaOpts | VerifySchema (LogLevel -> Bool) Bool

cmdParser :: Parser Cmd
cmdParser = hsubparser
Expand All @@ -41,7 +41,7 @@ cmdParser = hsubparser
(info
addParser
(progDesc
"Adds and applies a SQL migration (and all pending migrations as well), then updates on-disk schema files."
"Adds and applies a SQL migration (and all pending migrations as well), then updates expected db schema on-disk."
)
)
<> command
Expand Down Expand Up @@ -113,7 +113,7 @@ addParser =
"Specify the folder path where the .sql migration shall be put. If unspecified, the first folder in the 'CODD_MIGRATION_DIRS' environment variable will be used"
<> metavar "DESTFOLDER"
)
<*> verbositySwitch
<*> quietSwitch
<*> argument
sqlFilePathReader
( metavar "SQL-MIGRATION-PATH"
Expand Down Expand Up @@ -163,22 +163,12 @@ optionalSecondsOption defaultValue optFields = realToFrac
-- Watch out: DiffTime's Read instance reads value with an "s" suffixed!
where intParser = maybeReader (Text.readMaybe @Int)

verbositySwitch :: Parser Verbosity
verbositySwitch =
switch
(long "verbose" <> short 'v' <> help
"Prints detailed execution information to stdout."
)
<&> \case
True -> Verbose
False -> NonVerbose

quietSwitch :: Parser Verbosity
quietSwitch :: Parser (LogLevel -> Bool)
quietSwitch =
switch (long "quiet" <> short 'q' <> help "Hides some of the output.")
<&> \case
True -> NonVerbose
False -> Verbose
True -> (> LevelInfo)
False -> const True

main :: IO ()
main = do
Expand All @@ -192,7 +182,7 @@ main = do

doWork :: CoddSettings -> Cmd -> IO ()
doWork dbInfo (Up mCheckSchemas connectTimeout) =
runStdoutLoggingT $ case mCheckSchemas of
runCoddLogger $ case mCheckSchemas of
Nothing -> Codd.applyMigrationsNoCheck dbInfo
Nothing
connectTimeout
Expand All @@ -202,7 +192,8 @@ doWork dbInfo (Up mCheckSchemas connectTimeout) =
connectTimeout
checkSchemas
doWork dbInfo (Add addOpts destFolder verbosity fp) =
runVerbosityLogger verbosity $ addMigration dbInfo addOpts destFolder fp
runCoddLoggerLevelFilter verbosity
$ addMigration dbInfo addOpts destFolder fp
doWork dbInfo (VerifySchema verbosity fromStdin) =
runVerbosityLogger verbosity $ verifySchema dbInfo fromStdin
runCoddLoggerLevelFilter verbosity $ verifySchema dbInfo fromStdin
doWork dbInfo (WriteSchema opts) = writeSchema dbInfo opts
7 changes: 4 additions & 3 deletions codd.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -68,6 +68,7 @@ library
GeneralizedNewtypeDeriving
MultiParamTypeClasses
NamedFieldPuns
NumericUnderscores
OverloadedStrings
RankNTypes
RecordWildCards
Expand All @@ -84,14 +85,16 @@ library
build-depends:
aeson
, aeson-pretty
, ansi-terminal
, attoparsec
, base
, bytestring
, clock
, containers
, filepath
, formatting
, hashable
, haxl
, monad-logger
, mtl
, network-uri
, postgresql-libpq
Expand Down Expand Up @@ -147,7 +150,6 @@ executable codd
build-depends:
base
, codd
, monad-logger
, optparse-applicative
, postgresql-simple
, text
Expand Down Expand Up @@ -266,7 +268,6 @@ test-suite codd-test
, hspec
, hspec-core
, hspec-expectations
, monad-logger
, mtl
, network-uri
, postgresql-simple
Expand Down
6 changes: 3 additions & 3 deletions src/Codd.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -12,6 +12,7 @@ import Codd.Internal ( collectAndApplyMigrations
, laxCheckLastAction
, strictCheckLastAction
)
import Codd.Logging ( CoddLogger )
import Codd.Parsing ( AddedSqlMigration
, EnvVars
, hoistAddedSqlMigration
Expand All @@ -23,7 +24,6 @@ import Codd.Representations ( DbRep
, readRepsFromDisk
)
import Control.Monad.IO.Unlift ( MonadUnliftIO )
import Control.Monad.Logger ( MonadLogger )
import Control.Monad.Trans ( lift )
import Control.Monad.Trans.Resource ( MonadThrow )
import Data.Time ( DiffTime )
Expand All @@ -46,7 +46,7 @@ data ApplyResult = SchemasDiffer SchemasPair | SchemasMatch DbRep | SchemasNotVe
-- the Database's schema if they're not the ones expected or a success result otherwise.
-- Throws an exception if a migration fails or if schemas mismatch and strict-checking is enabled.
applyMigrations
:: (MonadUnliftIO m, MonadLogger m, MonadThrow m, EnvVars m, NotInTxn m)
:: (MonadUnliftIO m, CoddLogger m, MonadThrow m, EnvVars m, NotInTxn m)
=> CoddSettings
-> Maybe [AddedSqlMigration m]
-- ^ Instead of collecting migrations from disk according to codd settings, use these if they're defined.
Expand Down Expand Up @@ -84,7 +84,7 @@ applyMigrations dbInfo@CoddSettings { onDiskReps } mOverrideMigs connectTimeout
-- Throws an exception if a migration fails.
applyMigrationsNoCheck
:: ( MonadUnliftIO m
, MonadLogger m
, CoddLogger m
, MonadThrow m
, EnvVars m
, NotInTxn m
Expand Down
69 changes: 34 additions & 35 deletions src/Codd/AppCommands/AddMigration.hs
View file
Original file line number Diff line number Diff line change
@@ -1,4 +1,3 @@
{-# OPTIONS_GHC -Wno-unused-matches #-}
module Codd.AppCommands.AddMigration
( AddMigrationOptions(..)
, addMigration
Expand All @@ -14,6 +13,11 @@ import Codd.Environment ( CoddSettings(..) )
import Codd.Internal ( delayedOpenStreamFile
, listMigrationsFromDisk
)
import Codd.Logging ( CoddLogger
, logError
, logInfo
, logInfoAlways
)
import Codd.Parsing ( EnvVars
, parseSqlMigration
)
Expand All @@ -25,7 +29,6 @@ import Codd.Types ( SqlFilePath(..) )
import Control.Monad ( unless
, when
)
import Control.Monad.Logger ( MonadLoggerIO )
import Control.Monad.Trans.Resource ( MonadThrow )
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
Expand Down Expand Up @@ -55,12 +58,7 @@ newtype AddMigrationOptions = AddMigrationOptions

addMigration
:: forall m
. ( MonadUnliftIO m
, MonadLoggerIO m
, MonadThrow m
, EnvVars m
, NotInTxn m
)
. (MonadUnliftIO m, CoddLogger m, MonadThrow m, EnvVars m, NotInTxn m)
=> CoddSettings
-> AddMigrationOptions
-> Maybe FilePath
Expand All @@ -82,41 +80,40 @@ addMigration dbInfo@Codd.CoddSettings { onDiskReps, migsConnString, sqlMigration
onDiskReps

migFileExists <- doesFileExist fp
unless migFileExists $ liftIO $ do
Text.hPutStrLn stderr
unless migFileExists $ do
logError
$ "Could not find migration file \""
<> Text.pack fp
<> "\""
exitWith $ ExitFailure 99
liftIO $ exitWith $ ExitFailure 99

finalDirExists <- doesDirectoryExist finalDir
unless finalDirExists $ liftIO $ do
Text.hPutStrLn stderr
unless finalDirExists $ do
logError
$ "Could not find destination directory \""
<> Text.pack finalDir
<> "\""
exitWith $ ExitFailure 98
liftIO $ exitWith $ ExitFailure 98

expectedSchemaDirExists <- doesDirectoryExist onDiskRepsDir
unless expectedSchemaDirExists $ liftIO $ do
Text.hPutStrLn stderr
unless expectedSchemaDirExists $ do
logError
$ "Could not find directory for expected DB schema representation \""
<> Text.pack onDiskRepsDir
<> "\""
exitWith $ ExitFailure 97
liftIO $ exitWith $ ExitFailure 97

isFirstMigration <- null <$> listMigrationsFromDisk sqlMigrations []
runResourceT $ do
migStream <- delayedOpenStreamFile fp
parsedSqlMigE <- parseSqlMigration (takeFileName fp) migStream
case parsedSqlMigE of
Left err -> liftIO $ do
Text.hPutStrLn stderr
$ "Could not add migration: "
<> Text.pack err
when isFirstMigration
(printSuggestedFirstMigration migsConnString)
exitWith $ ExitFailure 96
Left err -> do
logError $ "Could not add migration " <> Text.pack err
liftIO $ when
isFirstMigration
(printSuggestedFirstMigration migsConnString)
liftIO $ exitWith $ ExitFailure 96

Right sqlMig -> do
migCheck <- checkMigration sqlMig
Expand All @@ -126,12 +123,12 @@ addMigration dbInfo@Codd.CoddSettings { onDiskReps, migsConnString, sqlMigration

case migError of
Nothing -> pure ()
Just err -> liftIO $ do
Text.hPutStrLn stderr $ "Error detected: " <> err
when
Just err -> do
logError err
liftIO $ when
isFirstMigration
(printSuggestedFirstMigration migsConnString)
exitWith $ ExitFailure 95
liftIO $ exitWith $ ExitFailure 95

finalMigFile <- timestampAndMoveMigrationFile sqlFp finalDir
addE <- try $ do
Expand All @@ -143,15 +140,17 @@ addMigration dbInfo@Codd.CoddSettings { onDiskReps, migsConnString, sqlMigration
(readRepresentationsFromDbWithSettings dbInfo)
persistRepsToDisk databaseSchemas onDiskRepsDir

liftIO
$ putStrLn
$ "Migration applied and added to "
<> finalMigFile
logInfoAlways
$ "New migration applied and added to "
<> Text.pack finalMigFile
logInfoAlways
$ "Updated expected DB schema representations in the <MAGENTA>"
<> Text.pack onDiskRepsDir
<> "</MAGENTA> folder"
when dontApply
$ liftIO
$ putStrLn
$ logInfo
$ "Migration was NOT applied, but was added to "
<> finalMigFile
<> Text.pack finalMigFile
case addE of
Right _ -> pure ()
Left (e :: SomeException) -> liftIO $ do
Expand Down
10 changes: 5 additions & 5 deletions src/Codd/AppCommands/VerifySchema.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -4,16 +4,16 @@ module Codd.AppCommands.VerifySchema

import Codd.Environment ( CoddSettings(..) )
import Codd.Internal ( withConnection )
import Codd.Logging ( CoddLogger
, logInfo
)
import Codd.Query ( NotInTxn )
import Codd.Representations ( logSchemasComparison
, readRepsFromDisk
)
import Codd.Representations.Database ( readRepsFromDbWithNewTxn )
import Codd.Representations.Types ( DbRep )
import Control.Monad ( when )
import Control.Monad.Logger ( MonadLoggerIO
, logInfoN
)
import Data.Aeson ( decode )
import Data.ByteString.Lazy ( hGetContents )
import Data.Maybe ( fromMaybe )
Expand All @@ -28,7 +28,7 @@ import UnliftIO ( MonadUnliftIO
)

verifySchema
:: (MonadUnliftIO m, MonadLoggerIO m, NotInTxn m)
:: (MonadUnliftIO m, CoddLogger m, NotInTxn m)
=> CoddSettings
-> Bool
-> m ()
Expand All @@ -53,4 +53,4 @@ verifySchema dbInfoWithAllMigs@CoddSettings { onDiskReps, migsConnString } fromS
when (dbSchema /= expectedSchemas) $ do
logSchemasComparison dbSchema expectedSchemas
liftIO $ exitWith (ExitFailure 1)
logInfoN "Database and expected schemas match."
logInfo "Actual and expected schemas <GREEN>match</GREEN>"
Loading

0 comments on commit fb5a4b1

Please sign in to comment.