packages feed

refurb (empty) → 0.2.1.0

raw patch · 14 files changed

+1048/−0 lines, 14 filesdep +Framesdep +ansi-wl-pprintdep +basesetup-changed

Dependencies added: Frames, ansi-wl-pprint, base, bytestring, classy-prelude, composite-base, composite-opaleye, dlist, fast-logger, hspec, lens, monad-logger, old-locale, opaleye, optparse-applicative, postgresql-simple, process, product-profunctors, refurb, template-haskell, text, these, thyme, vector-space

Files

+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ refurb.cabal view
@@ -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
+ src/Refurb.hs view
@@ -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
+ src/Refurb/Cli.hs view
@@ -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"+    )
+ src/Refurb/MigrationUtils.hs view
@@ -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)
+ src/Refurb/Run/Backup.hs view
@@ -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"
+ src/Refurb/Run/Info.hs view
@@ -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+
+ src/Refurb/Run/Internal.hs view
@@ -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")+
+ src/Refurb/Run/Migrate.hs view
@@ -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+
+ src/Refurb/Store.hs view
@@ -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+
+ src/Refurb/Types.hs view
@@ -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 }
+ test/Main.hs view
@@ -0,0 +1,8 @@+import ClassyPrelude+import MigrationUtilsSpec (migrationUtilsSuite)+import Test.Hspec (hspec)++main :: IO ()+main = hspec $ do+  migrationUtilsSuite+
+ test/MigrationUtilsSpec.hs view
@@ -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"]