diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2017 Confer Health, Inc. + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Confer Health nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/refurb.cabal b/refurb.cabal new file mode 100644 --- /dev/null +++ b/refurb.cabal @@ -0,0 +1,92 @@ +-- This file has been generated from package.yaml by hpack version 0.17.0. +-- +-- see: https://github.com/sol/hpack + +name: refurb +version: 0.2.1.0 +synopsis: Tools for maintaining a database +description: Tools for maintaining a database +category: Database +homepage: https://github.com/ConferHealth/refurb#readme +maintainer: oss@confer.care +copyright: 2017 Confer Health, Inc. +license: BSD3 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 + +library + hs-source-dirs: + src + default-extensions: Arrows ConstraintKinds DataKinds DeriveGeneric FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses NamedFieldPuns NoImplicitPrelude OverloadedStrings PatternSynonyms QuasiQuotes RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TypeApplications TypeFamilies TypeOperators ViewPatterns + ghc-options: -Wall -O2 + build-depends: + base >= 4.7 && < 5 + , Frames + , ansi-wl-pprint + , bytestring + , classy-prelude + , composite-base + , composite-opaleye + , dlist + , fast-logger + , lens + , monad-logger + , old-locale + , opaleye + , optparse-applicative + , postgresql-simple + , process + , product-profunctors + , template-haskell + , text + , these + , thyme + , vector-space + exposed-modules: + Refurb + Refurb.Cli + Refurb.MigrationUtils + Refurb.Run.Backup + Refurb.Run.Info + Refurb.Run.Internal + Refurb.Run.Migrate + Refurb.Store + Refurb.Types + default-language: Haskell2010 + +test-suite refurb-test + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: + test + default-extensions: Arrows ConstraintKinds DataKinds DeriveGeneric FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses NamedFieldPuns NoImplicitPrelude OverloadedStrings PatternSynonyms QuasiQuotes RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TypeApplications TypeFamilies TypeOperators ViewPatterns + ghc-options: -Wall -O2 -threaded -rtsopts -with-rtsopts=-N -fno-warn-orphans + build-depends: + base >= 4.7 && < 5 + , Frames + , ansi-wl-pprint + , bytestring + , classy-prelude + , composite-base + , composite-opaleye + , dlist + , fast-logger + , lens + , monad-logger + , old-locale + , opaleye + , optparse-applicative + , postgresql-simple + , process + , product-profunctors + , template-haskell + , text + , these + , thyme + , vector-space + , refurb + , hspec + other-modules: + MigrationUtilsSpec + default-language: Haskell2010 diff --git a/src/Refurb.hs b/src/Refurb.hs new file mode 100644 --- /dev/null +++ b/src/Refurb.hs @@ -0,0 +1,72 @@ +-- |Top level module of Refurb along which re-exports the library portion of Refurb ('Refurb.Types' and 'Refurb.MigrationUtils') +module Refurb + ( refurbMain + , module Refurb.MigrationUtils + , module Refurb.Types + ) where + +import ClassyPrelude +import Control.Monad.Logger (LogLevel(LevelDebug), filterLogger, logDebug, runStdoutLoggingT) +import qualified Database.PostgreSQL.Simple as PG +import qualified Options.Applicative as OA +import Refurb.Cli (Command(CommandMigrate, CommandShowLog, CommandShowMigration, CommandBackup), Opts(Opts, debug, command, configFile), optsParser) +import Refurb.MigrationUtils +import Refurb.Run.Backup (backup) +import Refurb.Run.Internal (Context(Context)) +import Refurb.Run.Info (showMigration, showLog) +import Refurb.Run.Migrate (migrate) +import Refurb.Store (isSchemaPresent, initializeSchema) +import Refurb.Types + +-- |Main entry point for refurbishing. +-- +-- In @refurb readDatabaseConnectionString migrations@, @readDatabaseConnectionString@ is a function taking the configuration file path from the command line +-- and yielding a pair of actual and loggable connection strings, and @migrations@ is a list of 'Migration' records to consider. +-- +-- For example: +-- +-- @ +-- module Main where +-- +-- import Refurb ('Migration', 'MonadMigration', 'execute_', 'schemaMigration', refurbMain) +-- +-- migrations :: ['Migration'] +-- migrations = +-- [ schemaMigration "create-my-table" createMyTable +-- ] +-- +-- createMyTable :: MonadMigration m => m () +-- createMyTable = +-- void $ execute_ "create table my_table (...)" +-- +-- main :: IO () +-- main = refurbMain readDatabaseConnInfo migrations +-- @ +refurbMain :: (FilePath -> IO ConnInfo) -> [Migration] -> IO () +refurbMain readConnInfo migrations = do + opts@(Opts {..}) <- OA.execParser optsParser + + connInfo <- readConnInfo configFile + + let logFilter = if debug + then \ _ _ -> True + else \ _ lvl -> lvl > LevelDebug + + runStdoutLoggingT . filterLogger logFilter $ do + $logDebug $ "Connecting to " <> tshow (connInfoAsLogString connInfo) + bracket (liftBase . PG.connectPostgreSQL $ connInfoAsConnString connInfo) (liftBase . PG.close) $ \ conn -> do + let context = Context opts conn connInfo migrations + + unlessM (isSchemaPresent conn) $ initializeSchema conn + + void . liftIO $ PG.execute_ conn "set search_path = 'public'" + flip runReaderT context $ + case command of + CommandMigrate goNoGo backupMay installSeedData -> + migrate goNoGo backupMay installSeedData + CommandShowLog -> + showLog + CommandShowMigration key -> + showMigration key + CommandBackup path -> + backup path diff --git a/src/Refurb/Cli.hs b/src/Refurb/Cli.hs new file mode 100644 --- /dev/null +++ b/src/Refurb/Cli.hs @@ -0,0 +1,129 @@ +-- |Module with @optparse-applicative@ parsers for and datatypes to represent the command line arguments. +module Refurb.Cli where + +import ClassyPrelude +import Frames ((:->)(Col)) +import qualified Options.Applicative as OA +import Refurb.Store (FQualifiedKey) + +-- |Newtype wrapper for the @--execute@ boolean (@True@ if given, @False@ if omitted) +newtype GoNoGo = GoNoGo Bool deriving (Eq, Show) + +-- |Newtype wrapper for the @--backup-first@ option to the @migrate@ command. +newtype PreMigrationBackup = PreMigrationBackup FilePath deriving (Eq, Show) + +-- |Newtype wrapper for the @--seed@ boolean (@True@ if given, @False@ if omitted) +newtype InstallSeedData = InstallSeedData Bool deriving (Eq, Show) + +-- |The various top level commands that can be requested by the user +data Command + = CommandMigrate GoNoGo (Maybe PreMigrationBackup) InstallSeedData + -- ^Migrate the database or show what migrations would be applied, possibly backing up beforehand. + | CommandShowLog + -- ^Show the migration status. + | CommandShowMigration FQualifiedKey + -- ^Show status of a particular migration with its log output. + | CommandBackup FilePath + -- ^Back up the database. + deriving (Eq, Show) + +-- |Option parser for the @migrate@ command +commandMigrateParser :: OA.ParserInfo Command +commandMigrateParser = + OA.info + ( + CommandMigrate + <$> ( GoNoGo <$> OA.switch + ( OA.long "execute" + <> OA.short 'e' + <> OA.help "Actually run migrations. Without this switch the migrations to run will be logged but none of them executed." + ) + ) + <*> ( OA.option (Just . PreMigrationBackup <$> OA.auto) + ( OA.value Nothing + <> OA.long "backup-first" + <> OA.short 'b' + <> OA.metavar "BACKUP-FILE" + <> OA.help "Back up the database before applying migrations. Has no effect without --execute." + ) + ) + <*> ( InstallSeedData <$> OA.switch + ( OA.long "seed" + <> OA.short 's' + <> OA.help "Apply seed scripts in addition to schema migrations. Not available on prod databases." + ) + ) + ) + ( OA.progDesc "Apply migrations to the database, or see which ones would be applied" ) + +-- |Option parser for the @show-log@ command +commandShowLogParser :: OA.ParserInfo Command +commandShowLogParser = + OA.info + ( + pure CommandShowLog + ) + ( OA.progDesc "Show migrations along with their status in the database" ) + +-- |Option parser for the @show-migration@ command +commandShowMigrationParser :: OA.ParserInfo Command +commandShowMigrationParser = + OA.info + ( + CommandShowMigration + <$> (Col . pack <$> OA.strArgument (OA.metavar "MIGRATION-KEY")) + ) + ( OA.progDesc "Show status of and log details for a particular migration" ) + +-- |Option parser for the @backup@ command +commandBackupParser :: OA.ParserInfo Command +commandBackupParser = + OA.info + ( + CommandBackup + <$> OA.strArgument (OA.metavar "BACKUP-FILE") + ) + ( OA.progDesc "Back up the database" ) + +-- |Structure holding the parsed command line arguments and options. +data Opts = Opts + { debug :: Bool + -- ^Whether to turn on debug logging to the console + , colorize :: Bool + -- ^Whether to colorize console output + , configFile :: FilePath + -- ^The configuration file where (presumably) the database connection information is stored + , command :: Command + -- ^Which command the user chose and the options for that command + } + +-- |Parser for the command line arguments +optsParser :: OA.ParserInfo Opts +optsParser = + OA.info + ( + OA.helper <*> ( + Opts + <$> OA.switch + ( OA.long "debug" + <> OA.short 'd' + <> OA.help "Turn on debug diagnostic logging" + ) + <*> (not <$> OA.switch (OA.long "no-color" <> OA.help "disable ANSI colorization")) + <*> OA.strOption + ( OA.long "config" + <> OA.short 'c' + <> OA.metavar "SERVER-CONFIG" + <> OA.help "Path to server config file to read database connection information from" + ) + <*> OA.hsubparser + ( OA.command "migrate" commandMigrateParser + <> OA.command "show-log" commandShowLogParser + <> OA.command "show-migration" commandShowMigrationParser + <> OA.command "backup" commandBackupParser + ) + ) + ) + ( OA.fullDesc + <> OA.header "Maintain server database" + ) diff --git a/src/Refurb/MigrationUtils.hs b/src/Refurb/MigrationUtils.hs new file mode 100644 --- /dev/null +++ b/src/Refurb/MigrationUtils.hs @@ -0,0 +1,164 @@ +-- |Utilities for writing migrations. +module Refurb.MigrationUtils where + +import ClassyPrelude +import Control.Monad.Logger (logDebug) +import Data.Profunctor.Product.Default (Default) +import qualified Data.Text as T +import qualified Database.PostgreSQL.Simple as PG +import Database.PostgreSQL.Simple.ToRow (toRow) +import Database.PostgreSQL.Simple.Types (fromQuery) +import qualified Language.Haskell.TH.Syntax as TH +import qualified Language.Haskell.TH.Quote as TH +import qualified Opaleye +import Opaleye.Internal.Table (tableIdentifier) +import Refurb.Types (MonadMigration) + +-- |Simple quasiquoter which just makes it easier to embed literal chunks of SQL in migrations. +-- +-- For example: +-- +-- @ +-- createStuffIndex :: MonadMigration m => m () +-- createStuffIndex = +-- execute_ +-- [qqSql| +-- create index stuff_index +-- on stuff (things) +-- where is_what_we_want_to_index = 't' +-- |] +-- @ +qqSql :: TH.QuasiQuoter +qqSql = TH.QuasiQuoter + { TH.quoteExp = \ s -> [| $(TH.lift s) :: PG.Query |] + , TH.quotePat = error "qqSql should only be used in an expression context" + , TH.quoteType = error "qqSql should only be used in an expression context" + , TH.quoteDec = error "qqSql should only be used in an expression context" + } + +-- |Quasiquoter which takes a block of literal SQL and converts it into a list of 'PG.Query' values, e.g. to pass to 'executeSeries_'. A semicolon at the +-- beginning or end of a line (sans whitespace) separates SQL statements. +-- +-- For example: +-- +-- @ +-- createStuff :: MonadMigration m => m () +-- createStuff = +-- executeSeries_ [qqSqls| +-- create sequence stuff_seq; +-- create table stuff +-- ( id bigint not null primary key default nextval('stuff_seq') +-- ); +-- |] +-- @ +qqSqls :: TH.QuasiQuoter +qqSqls = TH.QuasiQuoter + { TH.quoteExp = \ s -> [| $(bodyToStatements s) :: [PG.Query] |] + , TH.quotePat = error "qqSql should only be used in an expression context" + , TH.quoteType = error "qqSql should only be used in an expression context" + , TH.quoteDec = error "qqSql should only be used in an expression context" + } + where + bodyToStatements :: String -> TH.Q TH.Exp + bodyToStatements = TH.lift . map (unpack . unlines) . filter (not . null) . map (filter (not . null)) . go [] . lines . pack + where + go acc [] = [acc] + go acc ((T.strip -> l):ls) + | Just l' <- T.stripSuffix ";" =<< T.stripPrefix ";" l = + reverse acc : [l'] : go [] ls + | Just l' <- T.stripPrefix ";" l = + reverse acc : go [l'] ls + | Just l' <- T.stripSuffix ";" l = + reverse (l' : acc) : go [] ls + | otherwise = + go (l : acc) ls + +-- |Execute some parameterized SQL against the database connection. +-- Wraps 'PG.execute' using the 'MonadMigration' reader to get the connection. +execute :: (MonadMigration m, PG.ToRow q) => PG.Query -> q -> m Int64 +execute q p = do + conn <- ask + $logDebug $ decodeUtf8 (fromQuery q) <> " with " <> tshow (toRow p) + liftBase $ PG.execute conn q p + +-- |Execute some parameterized SQL against the database connection. +-- Wraps 'PG.executeMany' using the 'MonadMigration' reader to get the connection. +executeMany :: (MonadMigration m, PG.ToRow q) => PG.Query -> [q] -> m Int64 +executeMany q ps = do + conn <- ask + $logDebug $ decodeUtf8 (fromQuery q) <> " with [" + <> maybe "" ((if length ps > 1 then (<> ", ...") else id) . tshow . toRow) (headMay ps) <> "]" + liftBase $ PG.executeMany conn q ps + +-- |Execute some fixed SQL against the database connection. +-- Wraps 'PG.execute_' using the 'MonadMigration' reader to get the connection. +execute_ :: MonadMigration m => PG.Query -> m Int64 +execute_ q = do + conn <- ask + $logDebug . decodeUtf8 $ fromQuery q + liftBase $ PG.execute_ conn q + +-- |Execute a series of fixed SQL statements against the database connection. +-- Equivalent to `traverse_ (void . execute_)` +executeSeries_ :: MonadMigration m => [PG.Query] -> m () +executeSeries_ = traverse_ (void . execute_) + +-- |Run a parameterized query against the database connection. +-- Wraps 'PG.query' using the 'MonadMigration' reader to get the connection. +query :: (MonadMigration m, PG.ToRow q, PG.FromRow r) => PG.Query -> q -> m [r] +query q p = do + conn <- ask + $logDebug $ decodeUtf8 (fromQuery q) <> " with " <> tshow (toRow p) + liftBase $ PG.query conn q p + +-- |Run a fixed query against the database connection. +-- Wraps 'PG.query_' using the 'MonadMigration' reader to get the connection. +query_ :: (MonadMigration m, PG.FromRow r) => PG.Query -> m [r] +query_ q = do + conn <- ask + $logDebug . decodeUtf8 $ fromQuery q + liftBase $ PG.query_ conn q + +-- |Run an Opaleye query against the database connection. +-- Wraps 'Opaleye.runQuery' using the 'MonadMigration' reader to get the connection. +runQuery + :: ( MonadMigration m + , Default Opaleye.Unpackspec columns columns + , Default Opaleye.QueryRunner columns haskells + ) + => Opaleye.Query columns -> m [haskells] +runQuery q = do + conn <- ask + for_ (Opaleye.showSql q) ($logDebug . pack) + liftBase $ Opaleye.runQuery conn q + +-- |Run an Opaleye 'Opaleye.runInsertMany' against the database connection. +runInsertMany :: MonadMigration m => Opaleye.Table columns columns' -> [columns] -> m Int64 +runInsertMany table rows = do + conn <- ask + $logDebug $ "inserting " <> tshow (length rows) <> " rows into " <> tshow (tableIdentifier table) + liftBase $ Opaleye.runInsertMany conn table rows + +-- |Run an Opaleye 'Opaleye.runUpdate' against the database connection. +runUpdate :: MonadMigration m => Opaleye.Table columnsW columnsR -> (columnsR -> columnsW) -> (columnsR -> Opaleye.Column Opaleye.PGBool) -> m Int64 +runUpdate table permute filt = do + conn <- ask + $logDebug $ "updating " <> tshow (tableIdentifier table) + liftBase $ Opaleye.runUpdate conn table permute filt + +-- |Run an Opaleye 'Opaleye.runDelete' against the database connection. +runDelete :: MonadMigration m => Opaleye.Table columnsW columnsR -> (columnsR -> Opaleye.Column Opaleye.PGBool) -> m Int64 +runDelete table filt = do + conn <- ask + $logDebug $ "deleting from " <> tshow (tableIdentifier table) + liftBase $ Opaleye.runDelete conn table filt + +-- |Check if a schema exists using the @information_schema@ views. +doesSchemaExist :: MonadMigration m => Text -> m Bool +doesSchemaExist schema = + not . (null :: [PG.Only Int] -> Bool) <$> query "select 1 from information_schema.schemata where schema_name = ?" (PG.Only schema) + +-- |Check if a table exists in a schema using the @information_schema@ views. +doesTableExist :: MonadMigration m => Text -> Text -> m Bool +doesTableExist schema table = + not . (null :: [PG.Only Int] -> Bool) <$> query "select 1 from information_schema.tables where table_schema = ? and table_name = ?" (schema, table) diff --git a/src/Refurb/Run/Backup.hs b/src/Refurb/Run/Backup.hs new file mode 100644 --- /dev/null +++ b/src/Refurb/Run/Backup.hs @@ -0,0 +1,38 @@ +module Refurb.Run.Backup where + +import ClassyPrelude +import Control.Monad.Logger (logInfo, logError) +import Refurb.Run.Internal (MonadRefurb, contextDbConnInfo) +import Refurb.Types (ConnInfo(ConnInfo), connDbName, connUser, connHost, connPort, connPassword) +import System.Environment (getEnvironment) +import System.Exit (ExitCode(ExitSuccess, ExitFailure)) +import qualified System.Process as Proc + +-- |Handle the @backup@ command by calling @pg_dump@ to save a database backup. +backup :: MonadRefurb m => FilePath -> m () +backup path = do + ConnInfo {..} <- asks contextDbConnInfo + $logInfo $ "Backing up database to " <> tshow path + env <- liftBase getEnvironment + let createProcess = + ( Proc.proc "pg_dump" + [ "-Z", "9" -- max compression + , "-F", "c" -- "custom" format - custom to pg_dump / pg_restore + , "-f", path + , "-d", unpack connDbName + , "-U", unpack connUser + , "-h", unpack connHost + , "-p", show connPort + ] + ) { Proc.env = Just $ ("PGPASS", unpack connPassword) : env } + + (exitCode, out, err) <- liftBase $ Proc.readCreateProcessWithExitCode createProcess "" + + case exitCode of + ExitSuccess -> + $logInfo "Backup complete." + ExitFailure code -> do + $logError $ "Backup failed with code " <> tshow code + $logError $ "pg_dump stdout:\n" <> pack out + $logError $ "pg_dump stderr:\n" <> pack err + fail "pg_dump failed" diff --git a/src/Refurb/Run/Info.hs b/src/Refurb/Run/Info.hs new file mode 100644 --- /dev/null +++ b/src/Refurb/Run/Info.hs @@ -0,0 +1,73 @@ +module Refurb.Run.Info where + +import ClassyPrelude +import Composite.Base () +import Control.Arrow (returnA) +import Control.Lens (Getting, _Wrapped, each, preview, to, view) +import Data.Monoid (First) +import Data.These (These(This, That, These), there) +import Data.Thyme.Clock (NominalDiffTime, fromSeconds) +import Data.Thyme.Format.Human (humanTimeDiff) +import Frames (Record) +import Opaleye ((.==), constant, restrict) +import Refurb.Run.Internal (MonadRefurb, contextDbConn, contextMigrations, optionallyColoredM, migrationResultDoc) +import Refurb.Store (FQualifiedKey, MigrationLog, cQualifiedKey, fId, fApplied, fDuration, fOutput, fResult, fQualifiedKey, readMigrationStatus) +import Refurb.Types (Migration, MigrationType(MigrationSeedData), migrationQualifiedKey, migrationType) +import Text.PrettyPrint.ANSI.Leijen (Doc, (<+>), fill, bold, underline, black, red, white, parens, text) + +-- |Given a migration status as read by 'readMigrationStatus', pretty print that information as a table on stdout. +showMigrationStatus :: (MonadRefurb m, MonoTraversable t, Element t ~ These Migration (Record MigrationLog)) => t -> m () +showMigrationStatus migrationStatus = do + disp <- optionallyColoredM + disp . bold . underline $ row (text "ID") (text "Timestamp") (text "Duration") (text "Result") (text "Key") + for_ migrationStatus $ \ these -> + disp $ case these of + These m mlog -> mlogRow mlog <+> seedDoc m + This m -> row (text "") (text "not applied") (text "") (text "") (white . text . unpack $ migrationQualifiedKey m) <+> seedDoc m + That mlog -> mlogRow mlog <+> parens (red "not in known migrations") + + where + row :: Doc -> Doc -> Doc -> Doc -> Doc -> Doc + row i t d r k = fill 6 i <+> fill 19 t <+> fill 15 d <+> fill 7 r <+> k + + field :: Getting (First String) s String -> s -> Doc + field f = text . fromMaybe "" . preview f + + seedDoc :: Migration -> Doc + seedDoc (view migrationType -> mtype) + | mtype == MigrationSeedData = text "(seed data)" + | otherwise = mempty + + mlogRow :: Record MigrationLog -> Doc + mlogRow = + row + <$> field (fId . to show) + <*> view (fApplied . to (white . text . formatTime defaultTimeLocale "%F %T")) + <*> field (fDuration . to (humanTimeDiff . (fromSeconds :: Double -> NominalDiffTime))) + <*> view (fResult . to migrationResultDoc) + <*> view (fQualifiedKey . to (white . text . unpack)) + +-- |Implement the @show-log@ command by reading the entire migration log and displaying it with 'showMigrationStatus'. +showLog :: MonadRefurb m => m () +showLog = do + dbConn <- asks contextDbConn + migrations <- asks contextMigrations + migrationStatus <- readMigrationStatus dbConn migrations (proc _ -> returnA -< ()) + showMigrationStatus migrationStatus + +-- |Implement the @show-migration@ command by reading migration log pertaining to the given migration key and displaying it with 'showMigrationStatus' plus +-- its log output. +showMigration :: MonadRefurb m => FQualifiedKey -> m () +showMigration (view _Wrapped -> key) = do + disp <- optionallyColoredM + dbConn <- asks contextDbConn + migrations <- asks $ filter ((== key) . migrationQualifiedKey) . contextMigrations + migrationStatus <- readMigrationStatus dbConn migrations $ proc mlog -> + restrict -< view cQualifiedKey mlog .== constant key + + showMigrationStatus migrationStatus + putStrLn "" + case preview (each . there) migrationStatus of + Nothing -> disp . black $ "Never been run." -- n.b.: black is not black + Just mlog -> putStrLn . view fOutput $ mlog + diff --git a/src/Refurb/Run/Internal.hs b/src/Refurb/Run/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Refurb/Run/Internal.hs @@ -0,0 +1,47 @@ +-- |Module containing shared types and functions used for implementing the various commands. +module Refurb.Run.Internal where + +import ClassyPrelude +import Control.Monad.Logger (MonadLogger, MonadLoggerIO) +import qualified Database.PostgreSQL.Simple as PG +import Refurb.Cli (Opts, colorize) +import Refurb.Store (MigrationResult(MigrationSuccess, MigrationFailure)) +import Refurb.Types (ConnInfo, Migration) +import Text.PrettyPrint.ANSI.Leijen (Doc, green, red, plain, text, putDoc) + +-- |Reader context for all command execution which contains the command line options, database connection and connection information, and known migrations. +data Context = Context + { contextOptions :: Opts + -- ^The 'Opts' structure parsed from the command line by @Refurb.Cli@. + , contextDbConn :: PG.Connection + -- ^The open database 'PG.Connection'. + , contextDbConnInfo :: ConnInfo + -- ^The information used to connect to the database, required for running command line tools like @pg_dump@ against the same database. + , contextMigrations :: [Migration] + -- ^The known migrations passed in to 'Refurb.refurbMain'. + } + +-- |Constraint of actions for command execution, including access to the 'Context', logging, and underlying IO. +type MonadRefurb m = (MonadBaseControl IO m, MonadMask m, MonadReader Context m, MonadLogger m, MonadLoggerIO m) + +-- |Given the configuration implicitly available to 'MonadRefurb', produce a function which possibly strips ANSI colorization from a 'Doc' if the user +-- requested colorless output. +optionallyColorM :: MonadRefurb m => m (Doc -> Doc) +optionallyColorM = + bool plain id <$> asks (colorize . contextOptions) + +-- |Given the configuration implicitly available to 'MonadRefurb', produce a function which emits a 'Doc' on stdout that is colored unless the user requested +-- colorless output. +optionallyColoredM :: MonadRefurb m => m (Doc -> m ()) +optionallyColoredM = do + maybePlain <- optionallyColorM + pure $ \ doc -> do + liftBase $ putDoc (maybePlain doc) + putStrLn "" + +-- |Produce a colorized 'Doc' with @success@ or @failure@, based on which 'MigrationResult' value was passed. +migrationResultDoc :: MigrationResult -> Doc +migrationResultDoc = \ case + MigrationSuccess -> green (text "success") + MigrationFailure -> red (text "failure") + diff --git a/src/Refurb/Run/Migrate.hs b/src/Refurb/Run/Migrate.hs new file mode 100644 --- /dev/null +++ b/src/Refurb/Run/Migrate.hs @@ -0,0 +1,122 @@ +module Refurb.Run.Migrate where + +import ClassyPrelude hiding ((), defaultTimeLocale, getCurrentTime, formatTime) +import Control.Arrow (returnA) +import Control.Monad.Logger (askLoggerIO, runLoggingT) +import Control.Lens (each, toListOf, view) +import Data.AffineSpace ((.-.)) +import qualified Data.DList as DL +import Data.These (_This) +import Data.Thyme.Clock (NominalDiffTime, getCurrentTime, toSeconds) +import Data.Thyme.Format (formatTime) +import Data.Thyme.Format.Human (humanTimeDiff) +import Data.Thyme.Time.Core (fromThyme) +import qualified Database.PostgreSQL.Simple as PG +import qualified Database.PostgreSQL.Simple.Types as PG +import Frames (Record, (&:), pattern Nil) +import Language.Haskell.TH (Loc, loc_package, loc_module, loc_filename, loc_start) +import Opaleye (constant, runInsertMany) +import Refurb.Cli (GoNoGo(GoNoGo), PreMigrationBackup(PreMigrationBackup), InstallSeedData(InstallSeedData)) +import Refurb.MigrationUtils (doesSchemaExist) +import Refurb.Run.Backup (backup) +import Refurb.Run.Internal (MonadRefurb, contextDbConn, contextMigrations, optionallyColoredM) +import Refurb.Store (MigrationLogW, MigrationLogColsW, MigrationResult(MigrationSuccess, MigrationFailure), migrationLog, isProdSystem, readMigrationStatus) +import Refurb.Types (Migration, migrationQualifiedKey, migrationSchema, migrationType, migrationCheck, migrationExecute, MigrationType(MigrationSchema)) +import System.Exit (exitFailure) +import System.Locale (defaultTimeLocale) +import System.Log.FastLogger (LogStr, fromLogStr, toLogStr) +import Text.PrettyPrint.ANSI.Leijen (Doc, (), (<+>), hang, fillSep, red, green, white, text) + +-- |Helper which produces the standard prefix 'Doc' for a given migration: @migration key: @ with color. +migrationPrefixDoc :: Migration -> Doc +migrationPrefixDoc migration = white (text . unpack . migrationQualifiedKey $ migration) ++ text ":" + +-- |Implement the @migrate@ command by verifying that seed data is only applied to non-production databases, reading the migration status, and determining +-- from that status which migrations to apply. If the user requested execution of migrations, delegate to 'applyMigrations' to actually do the work. +migrate :: MonadRefurb m => GoNoGo -> Maybe PreMigrationBackup -> InstallSeedData -> m () +migrate (GoNoGo isGo) backupMay (InstallSeedData shouldInstallSeedData) = do + disp <- optionallyColoredM + dbConn <- asks contextDbConn + migrations <- asks contextMigrations + + when shouldInstallSeedData $ + whenM (isProdSystem dbConn) $ do + disp . red . text $ "Refusing to install seed data on production system." + liftBase exitFailure + + migrationStatus <- readMigrationStatus dbConn (filter useMigration migrations) (proc _ -> returnA -< ()) + + let migrationsToApply = toListOf (each . _This) migrationStatus + disp . hang 2 $ "Migrations to apply: " fillSep (map ((++ text ",") . white . text . unpack . migrationQualifiedKey) migrationsToApply) + + if isGo + then traverse_ (\ (PreMigrationBackup path) -> backup path) backupMay >> applyMigrations migrationsToApply + else disp $ text "Not applying migrations without --execute" + + where + useMigration m = view migrationType m == MigrationSchema || shouldInstallSeedData + +-- |Given a pre-vetted list of 'Migration' structures to apply to the database, iterate through them and run their check actions (if any) followed by +-- execution actions with log output captured. +applyMigrations :: MonadRefurb m => [Migration] -> m () +applyMigrations migrations = do + disp <- optionallyColoredM + dbConn <- asks contextDbConn + + for_ migrations $ \ migration -> do + let schema = view migrationSchema migration + unlessM (runReaderT (doesSchemaExist schema) dbConn) $ + void . liftIO $ PG.execute_ dbConn (PG.Query $ "create schema " <> encodeUtf8 schema) + + void . liftIO $ PG.execute dbConn "set search_path = ?" (PG.Only $ view migrationSchema migration) + + for_ (view migrationCheck migration) $ \ check -> + onException + ( do runReaderT check dbConn + disp $ migrationPrefixDoc migration <+> green (text "check passed") ) + ( disp $ migrationPrefixDoc migration <+> red (text "check failed") ) + + outputRef <- liftBase $ newIORef (mempty :: DList ByteString) + start <- liftBase getCurrentTime + + let insertLog result = do + end <- liftBase getCurrentTime + output <- decodeUtf8 . concat . intersperse "\n" <$> liftBase (readIORef outputRef) + let duration = end .-. start + suffix = text "after" <+> text (humanTimeDiff duration) + + case result of + MigrationSuccess -> disp $ migrationPrefixDoc migration <+> green (text "success") <+> suffix + MigrationFailure -> do disp $ migrationPrefixDoc migration <+> red (text "failure") <+> suffix + putStrLn output + + void . liftIO $ PG.execute_ dbConn "set search_path = 'public'" + liftIO . runInsertMany dbConn migrationLog . singleton . (constant :: Record MigrationLogW -> Record MigrationLogColsW) $ + Nothing &: migrationQualifiedKey migration &: fromThyme start &: output &: result &: (toSeconds :: NominalDiffTime -> Double) duration &: Nil + + onException + ( do + logFunc <- askLoggerIO + runLoggingT (runReaderT (view migrationExecute migration) dbConn) $ \ loc src lvl str -> do + logFunc loc src lvl str + dateLogStr <- nowLogString + let message = fromLogStr $ dateLogStr <> " [" <> (toLogStr . show) lvl <> "] " <> str <> " @(" <> locLogString loc <> ")" + modifyIORef' outputRef (`DL.snoc` message) + insertLog MigrationSuccess ) + ( insertLog MigrationFailure ) + +-- |Format a 'Loc' in the way we want for logging output - @package:module filename:line:column@ +locLogString :: Loc -> LogStr +locLogString loc = p <> ":" <> m <> " " <> f <> ":" <> l <> ":" <> c + where p = toLogStr . loc_package $ loc + m = toLogStr . loc_module $ loc + f = toLogStr . loc_filename $ loc + l = toLogStr . show . fst . loc_start $ loc + c = toLogStr . show . snd . loc_start $ loc + +-- |Format the current timestamp in the way we want for logging output - @yyyy-mm-dd hh:mm:ss.SSS@ +nowLogString :: IO LogStr +nowLogString = do + now <- getCurrentTime + pure . toLogStr $ formatTime defaultTimeLocale "%Y-%m-%d %T%Q" now + diff --git a/src/Refurb/Store.hs b/src/Refurb/Store.hs new file mode 100644 --- /dev/null +++ b/src/Refurb/Store.hs @@ -0,0 +1,138 @@ +-- |Module containing definition of and functions for maintaining the in-database state storage for Refurb. +module Refurb.Store where + +import ClassyPrelude +import Composite.Opaleye (defaultRecTable) +import Composite.Opaleye.TH (deriveOpaleyeEnum) +import Composite.TH (withLensesAndProxies) +import Control.Arrow (returnA) +import Control.Lens (view) +import Control.Monad.Logger (MonadLogger, logDebug) +import Data.These (These(This, These, That)) +import qualified Database.PostgreSQL.Simple as PG +import Frames ((:->), Record) +import Opaleye (Column, PGBool, PGInt4, PGFloat8, PGText, PGTimestamptz, QueryArr, Table(TableWithSchema), asc, orderBy, queryTable, runQuery) +import Refurb.MigrationUtils (doesTableExist, qqSqls) +import Refurb.Types (Migration, migrationQualifiedKey) + +-- |Result of running a migration, either success or failure. +data MigrationResult + = MigrationSuccess + | MigrationFailure + deriving (Eq, Show) + +deriveOpaleyeEnum ''MigrationResult "migration_result_enum" (stripPrefix "migration" . toLower) + +withLensesAndProxies [d| + type FId = "id" :-> Int32 + type FIdMay = "id" :-> Maybe Int32 + type CId = "id" :-> Column PGInt4 + type CIdMay = "id" :-> Maybe (Column PGInt4) + type FQualifiedKey = "qualified_key" :-> Text + type CQualifiedKey = "qualified_key" :-> Column PGText + type FApplied = "applied" :-> UTCTime + type CApplied = "applied" :-> Column PGTimestamptz + type FOutput = "output" :-> Text + type COutput = "output" :-> Column PGText + type FResult = "result" :-> MigrationResult + type CResult = "result" :-> Column PGMigrationResult + type FDuration = "duration" :-> Double + type CDuration = "duration" :-> Column PGFloat8 + + type FProdSystem = "prod_system" :-> Bool + type CProdSystem = "prod_system" :-> Column PGBool + |] + +-- |Fields of a migration log entry in memory fetched from the database (with ID) +type MigrationLog = '[FId , FQualifiedKey, FApplied, FOutput, FResult, FDuration] +-- |Fields of a migration log entry to insert in the database (with the ID column optional) +type MigrationLogW = '[FIdMay, FQualifiedKey, FApplied, FOutput, FResult, FDuration] +-- |Columns of a migration log when reading from the database (with ID) +type MigrationLogColsR = '[CId , CQualifiedKey, CApplied, COutput, CResult, CDuration] +-- |Columns of a migration log when inserting into the database (with ID column optional) +type MigrationLogColsW = '[CIdMay, CQualifiedKey, CApplied, COutput, CResult, CDuration] + +-- |Fields of the Refurb config in memory +type RefurbConfig = '[FProdSystem] +-- |Columns of the Refurb config in the database +type RefurbConfigCols = '[CProdSystem] + +-- |The migration log table which records all executed migrations and their results +migrationLog :: Table (Record MigrationLogColsW) (Record MigrationLogColsR) +migrationLog = TableWithSchema "refurb" "migration_log" defaultRecTable + +-- |The refurb config table which controls whether this database is considered a production one or not +refurbConfig :: Table (Record RefurbConfigCols) (Record RefurbConfigCols) +refurbConfig = TableWithSchema "refurb" "config" defaultRecTable + +-- |Test to see if the schema seems to be installed by looking for an existing refurb_config table +isSchemaPresent :: (MonadBaseControl IO m, MonadMask m, MonadLogger m) => PG.Connection -> m Bool +isSchemaPresent conn = do + $logDebug "Checking if schema present" + runReaderT (doesTableExist "refurb" "config") conn + +-- |Check if this database is configured as a production database by reading the refurb config table +isProdSystem :: (MonadBaseControl IO m, MonadLogger m) => PG.Connection -> m Bool +isProdSystem conn = do + $logDebug "Checking if this is a prod system" + map (fromMaybe False . headMay) . liftBase . runQuery conn $ proc () -> do + config <- queryTable refurbConfig -< () + returnA -< view cProdSystem config + +-- |Create the refurb schema elements. Will fail if they already exist. +initializeSchema :: (MonadBaseControl IO m, MonadLogger m) => PG.Connection -> m () +initializeSchema conn = do + $logDebug "Initializing refurb schema" + + liftBase $ traverse_ (void . PG.execute_ conn) [qqSqls| + create schema refurb; + set search_path = 'refurb'; + create type migration_result_enum as enum('success', 'failure'); + create table config (prod_system boolean not null); + insert into config (prod_system) values (false); + create sequence migration_log_serial; + create table migration_log + ( id int not null + primary key + default nextval('migration_log_serial') + , qualified_key text not null + unique + , applied timestamptz not null + , output text not null + , result migration_result_enum not null + , duration double precision not null + ); + |] + +-- |Read the migration log and stitch it together with the expected migration list, forming a list in the same order as the known migrations but with +-- 'These' representing whether the migration log for the known migration is present or not. +-- +-- * @'This' migration@ represents a known migration that has no log entry. +-- * @'That' migrationLog@ represents an unknown migration that was applied in the past. +-- * @'These' migration migrationLog@ represents a migration that has an attempted application in the log. +readMigrationStatus + :: (MonadBaseControl IO m, MonadLogger m) + => PG.Connection + -> [Migration] + -> QueryArr (Record MigrationLogColsR) () + -> m [These Migration (Record MigrationLog)] +readMigrationStatus conn migrations restriction = do + $logDebug "Reading migration status" + migrationStatus <- liftBase $ runQuery conn . orderBy (asc $ view cQualifiedKey) $ proc () -> do + mlog <- queryTable migrationLog -< () + restriction -< mlog + returnA -< mlog + + let migrationLogByKey = mapFromList . map (view fQualifiedKey &&& id) $ migrationStatus + + alignMigration + :: Migration + -> ([These Migration (Record MigrationLog)], Map Text (Record MigrationLog)) + -> ([These Migration (Record MigrationLog)], Map Text (Record MigrationLog)) + alignMigration m@(migrationQualifiedKey -> k) (t, l) = + first ((:t) . maybe (This m) (These m)) (updateLookupWithKey (\ _ _ -> Nothing) k l) + + (aligned, extra) = foldr alignMigration ([], migrationLogByKey) migrations + + pure $ map That (toList extra) ++ aligned + diff --git a/src/Refurb/Types.hs b/src/Refurb/Types.hs new file mode 100644 --- /dev/null +++ b/src/Refurb/Types.hs @@ -0,0 +1,110 @@ +-- |Module containing externally useful types for Refurb, most notably the 'Migration' type. +module Refurb.Types + ( ConnInfo(..) + , connInfoAsConnString, connInfoAsLogString + , MigrationType(..) + , MonadMigration + , Migration(..), migrationSchema, migrationKey, migrationType, migrationCheck, migrationExecute, migrationQualifiedKey + , schemaMigration, seedDataMigration, withCheck + ) where + +import ClassyPrelude +import Control.Lens.TH (makeLenses) +import Control.Monad.Logger (MonadLogger) +import qualified Data.ByteString.Char8 as BSC8 +import Data.Word (Word16) +import qualified Database.PostgreSQL.Simple as PG + +-- |Structure with connection information for connecting to the database. +data ConnInfo = ConnInfo + { connHost :: Text + -- ^Hostname or IP address of the PostgreSQL server. + , connPort :: Word16 + -- ^Port number the PostgreSQL server is running on (usually @5432@). + , connUser :: Text + -- ^What user to connect to the database as. + , connPassword :: Text + -- ^What password to connect to the database with. + , connDbName :: Text + -- ^What database in the PostgreSQL server to attach to. + } + +-- |Given a 'ConnInfo' generate the connection string pairs that are shared between the loggable and real version, that is all of them except password. +commonParams :: ConnInfo -> [(ByteString, ByteString)] +commonParams (ConnInfo {..}) = + [ ("host", encodeUtf8 connHost) + , ("port", encodeUtf8 . tshow $ connPort) + , ("user", encodeUtf8 connUser) + , ("dbname", encodeUtf8 connDbName) + ] + +-- |Given a list of key/value pairs, make up a @key1=value1 key2=value2@ string that PostgreSQL expects. +asConnString :: [(ByteString, ByteString)] -> ByteString +asConnString = BSC8.intercalate " " . map (\ (key, val) -> key <> "=" <> val) + +-- |Given a 'ConnInfo' make up the real connection string to pass when connecting to the database. Includes password, so never log this. +connInfoAsConnString :: ConnInfo -> ByteString +connInfoAsConnString connInfo@(ConnInfo { connPassword }) = + asConnString (("password", encodeUtf8 connPassword) : commonParams connInfo) + +-- |Given a 'ConnInfo' make up the log-safe connection string to show to humans, which omits the password. +connInfoAsLogString :: ConnInfo -> Text +connInfoAsLogString = + decodeUtf8 . asConnString . commonParams + +-- |Enumeration of the types of migration that are known about. +data MigrationType + = MigrationSchema + -- ^Migration that updates the schema of the database and should be run everywhere. + | MigrationSeedData + -- ^Migration that installs or replaces data for testing purposes and should never be run in production. + deriving (Eq, Show) + +-- |Constraint for actions run in the context of a migration, with access to underlying IO, PostgreSQL connection, and logging. +type MonadMigration m = (MonadBaseControl IO m, MonadMask m, MonadReader PG.Connection m, MonadLogger m) + +-- |Data type of a migration, with its key, type, and actions. +data Migration = Migration + { _migrationSchema :: Text + -- ^Schema for the migration to run in, which also qualifies the migration key." + , _migrationKey :: Text + -- ^Unique key to identify this migration among all known migrations. Never reuse keys, as they're the only link between the stored migration log and known + -- migrations. + , _migrationType :: MigrationType + -- ^What type of migration this is. + , _migrationCheck :: forall m. MonadMigration m => Maybe (m ()) + -- ^Optional action to execute before the primary execution to verify preconditions. + , _migrationExecute :: forall m. MonadMigration m => m () + -- ^Main migration action, such as creating tables or updating data. + } + +-- |The fully qualified key of the migration, schema.key +migrationQualifiedKey :: Migration -> Text +migrationQualifiedKey (Migration { _migrationSchema, _migrationKey }) = + _migrationSchema <> "." <> _migrationKey + +makeLenses ''Migration + +-- |Helper to construct a 'MigrationSchema' type 'Migration' with the given execution action and no check action. +schemaMigration :: Text -> Text -> (forall m. MonadMigration m => m ()) -> Migration +schemaMigration schema key execute = Migration + { _migrationSchema = schema + , _migrationKey = key + , _migrationType = MigrationSchema + , _migrationCheck = Nothing + , _migrationExecute = execute + } + +-- |Helper to construct a 'MigrationSeedData' type 'Migration' with the given execution action and no check action. +seedDataMigration :: Text -> Text -> (forall m. MonadMigration m => m ()) -> Migration +seedDataMigration schema key execute = Migration + { _migrationSchema = schema + , _migrationKey = key + , _migrationType = MigrationSeedData + , _migrationCheck = Nothing + , _migrationExecute = execute + } + +-- |Attach a check function to a 'Migration'. +withCheck :: Migration -> (forall m. MonadMigration m => m ()) -> Migration +withCheck m c = m { _migrationCheck = Just c } diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,8 @@ +import ClassyPrelude +import MigrationUtilsSpec (migrationUtilsSuite) +import Test.Hspec (hspec) + +main :: IO () +main = hspec $ do + migrationUtilsSuite + diff --git a/test/MigrationUtilsSpec.hs b/test/MigrationUtilsSpec.hs new file mode 100644 --- /dev/null +++ b/test/MigrationUtilsSpec.hs @@ -0,0 +1,23 @@ +module MigrationUtilsSpec where + +import ClassyPrelude +import Refurb.MigrationUtils +import Test.Hspec (Spec, describe, it, shouldBe) + +migrationUtilsSuite :: Spec +migrationUtilsSuite = + describe "MigrationUtils" $ do + it "can quote literal SQL" $ do + [qqSql|foo|] `shouldBe` "foo" + + it "can quote a series of literal SQL statements" $ do + [qqSqls|foo|] `shouldBe` ["foo\n"] + + [qqSqls| + do + a + thing; + and another thing + ;this thing too + ;but also this; + |] `shouldBe` ["do\na\nthing\n", "and another thing\n", "this thing too\n", "but also this\n"]