-- |
-- Module      : Database.PostgreSQL.Simple.Migration
-- Copyright   : (c) 2014 Andreas Meingast <ameingast@gmail.com>
--
-- License     : BSD-style
-- Maintainer  : andre@andrevdm.com
-- Stability   : experimental
-- Portability : GHC
--
-- A migration library for postgresql-simple.
--
-- For usage, see Readme.markdown.

{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}

module Database.PostgreSQL.Simple.Migration
    (
    -- * Migration actions
      defaultOptions
    , runMigration
    , runMigrations
    , sequenceMigrations

    -- * Migration types
    , Checksum
    , MigrationOptions(..)
    , MigrationCommand(..)
    , MigrationResult(..)
    , ScriptName
    , TransactionControl(..)
    , Verbosity(..)

    -- * Migration result actions
    , getMigrations
    , getMigrations'

    -- * Migration result types
    , SchemaMigration(..)
    ) where

import           Control.Monad (void, when)
import qualified Crypto.Hash.MD5 as MD5 (hash)
import qualified Data.ByteString as BS (ByteString, readFile)
import qualified Data.ByteString.Char8 as BS8 (unpack)
import qualified Data.ByteString.Base64 as B64 (encode)
import           Data.Functor ((<&>))
import           Data.List (isPrefixOf, sort)
import           Data.Time (LocalTime)
import qualified Data.Text as T
import qualified Data.Text.IO as T (putStrLn, hPutStrLn)
import           Data.String (fromString)
import           Database.PostgreSQL.Simple ( Connection
                                            , Only (..)
                                            , execute
                                            , execute_
                                            , query
                                            , query_
                                            , withTransaction
                                            )
import           Database.PostgreSQL.Simple.FromRow (FromRow (..), field)
import           Database.PostgreSQL.Simple.ToField (ToField (..))
import           Database.PostgreSQL.Simple.ToRow (ToRow (..))
import           Database.PostgreSQL.Simple.Types (Query (..))
import           Database.PostgreSQL.Simple.Util (existsTable)
import           System.Directory (getDirectoryContents)
import           System.FilePath ((</>))
import           System.IO (stderr)

-- | Executes migrations inside the provided 'MigrationContext'.
--
-- Returns 'MigrationSuccess' if the provided 'MigrationCommand' executes
-- without error. If an error occurs, execution is stopped and
-- a 'MigrationError' is returned.
runMigration :: Connection -> MigrationOptions -> MigrationCommand -> IO (MigrationResult String)
runMigration :: Connection
-> MigrationOptions
-> MigrationCommand
-> IO (MigrationResult ScriptName)
runMigration Connection
con MigrationOptions
opts MigrationCommand
cmd = Bool
-> Connection
-> MigrationOptions
-> [MigrationCommand]
-> IO (MigrationResult ScriptName)
runMigrations' Bool
True Connection
con MigrationOptions
opts [MigrationCommand
cmd]


-- | Execute a sequence of migrations
--
-- Returns 'MigrationSuccess' if all of the provided 'MigrationCommand's
-- execute without error. If an error occurs, execution is stopped and the
-- 'MigrationError' is returned.
runMigrations
  :: Connection -- ^ The postgres connection to use
  -> MigrationOptions -- ^ The options for this migration
  -> [MigrationCommand] -- ^ The commands to run
  -> IO (MigrationResult String)
runMigrations :: Connection
-> MigrationOptions
-> [MigrationCommand]
-> IO (MigrationResult ScriptName)
runMigrations = Bool
-> Connection
-> MigrationOptions
-> [MigrationCommand]
-> IO (MigrationResult ScriptName)
runMigrations' Bool
True



-- | Implements runMigration. Ensure that 'doRunTransaction' is only called on the first run
runMigration' :: Connection -> MigrationOptions -> MigrationCommand -> IO (MigrationResult String)
runMigration' :: Connection
-> MigrationOptions
-> MigrationCommand
-> IO (MigrationResult ScriptName)
runMigration' Connection
con MigrationOptions
opts MigrationCommand
cmd =
  case MigrationCommand
cmd of
    MigrationCommand
MigrationInitialization ->
      Connection -> MigrationOptions -> IO ()
initializeSchema Connection
con MigrationOptions
opts forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. MigrationResult a
MigrationSuccess
    MigrationDirectory ScriptName
path ->
      Connection
-> MigrationOptions
-> ScriptName
-> IO (MigrationResult ScriptName)
executeDirectoryMigration Connection
con MigrationOptions
opts ScriptName
path
    MigrationScript ScriptName
name ByteString
contents ->
      Connection
-> MigrationOptions
-> ScriptName
-> ByteString
-> IO (MigrationResult ScriptName)
executeMigration Connection
con MigrationOptions
opts ScriptName
name ByteString
contents
    MigrationFile ScriptName
name ScriptName
path ->
      Connection
-> MigrationOptions
-> ScriptName
-> ByteString
-> IO (MigrationResult ScriptName)
executeMigration Connection
con MigrationOptions
opts ScriptName
name forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ScriptName -> IO ByteString
BS.readFile ScriptName
path
    MigrationValidation MigrationCommand
validationCmd ->
      Connection
-> MigrationOptions
-> MigrationCommand
-> IO (MigrationResult ScriptName)
executeValidation Connection
con MigrationOptions
opts MigrationCommand
validationCmd
    MigrationCommands [MigrationCommand]
commands ->
      Bool
-> Connection
-> MigrationOptions
-> [MigrationCommand]
-> IO (MigrationResult ScriptName)
runMigrations' Bool
False Connection
con MigrationOptions
opts [MigrationCommand]
commands


-- | Implements runMigrations
runMigrations'
  :: Bool -- ^ Is this the first/top-level call
  -> Connection -- ^ The postgres connection to use
  -> MigrationOptions -- ^ The options for this migration
  -> [MigrationCommand] -- ^ The commands to run
  -> IO (MigrationResult String)
runMigrations' :: Bool
-> Connection
-> MigrationOptions
-> [MigrationCommand]
-> IO (MigrationResult ScriptName)
runMigrations' Bool
isFirst Connection
con MigrationOptions
opts [MigrationCommand]
commands =
  if Bool
isFirst
    then forall a. MigrationOptions -> Connection -> IO a -> IO a
doRunTransaction MigrationOptions
opts Connection
con IO (MigrationResult ScriptName)
go
    else IO (MigrationResult ScriptName)
go
  where
    go :: IO (MigrationResult ScriptName)
go = forall (m :: * -> *) e.
Monad m =>
[m (MigrationResult e)] -> m (MigrationResult e)
sequenceMigrations [Connection
-> MigrationOptions
-> MigrationCommand
-> IO (MigrationResult ScriptName)
runMigration' Connection
con MigrationOptions
opts MigrationCommand
c | MigrationCommand
c <- [MigrationCommand]
commands]



-- | Run a sequence of contexts, stopping on the first failure
sequenceMigrations
    :: Monad m
    => [m (MigrationResult e)]
    -> m (MigrationResult e)
sequenceMigrations :: forall (m :: * -> *) e.
Monad m =>
[m (MigrationResult e)] -> m (MigrationResult e)
sequenceMigrations = \case
  [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. MigrationResult a
MigrationSuccess
  m (MigrationResult e)
c:[m (MigrationResult e)]
cs -> do
    MigrationResult e
r <- m (MigrationResult e)
c
    case MigrationResult e
r of
      MigrationError e
s -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> MigrationResult a
MigrationError e
s)
      MigrationResult e
MigrationSuccess -> forall (m :: * -> *) e.
Monad m =>
[m (MigrationResult e)] -> m (MigrationResult e)
sequenceMigrations [m (MigrationResult e)]
cs

-- | Executes all SQL-file based migrations located in the provided 'dir'
-- in alphabetical order.
executeDirectoryMigration
  :: Connection
  -> MigrationOptions
  -> FilePath
  -> IO (MigrationResult String)
executeDirectoryMigration :: Connection
-> MigrationOptions
-> ScriptName
-> IO (MigrationResult ScriptName)
executeDirectoryMigration Connection
con MigrationOptions
opts ScriptName
dir =
  ScriptName -> IO [ScriptName]
scriptsInDirectory ScriptName
dir forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [ScriptName] -> IO (MigrationResult ScriptName)
go
  where
    go :: [ScriptName] -> IO (MigrationResult ScriptName)
go [ScriptName]
fs = forall (m :: * -> *) e.
Monad m =>
[m (MigrationResult e)] -> m (MigrationResult e)
sequenceMigrations (ScriptName -> IO (MigrationResult ScriptName)
executeMigrationFile forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ScriptName]
fs)
    executeMigrationFile :: ScriptName -> IO (MigrationResult ScriptName)
executeMigrationFile ScriptName
f =
      ScriptName -> IO ByteString
BS.readFile (ScriptName
dir ScriptName -> ScriptName -> ScriptName
</> ScriptName
f) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Connection
-> MigrationOptions
-> ScriptName
-> ByteString
-> IO (MigrationResult ScriptName)
executeMigration Connection
con MigrationOptions
opts ScriptName
f


-- | Lists all files in the given 'FilePath' 'dir' in alphabetical order.
scriptsInDirectory :: FilePath -> IO [String]
scriptsInDirectory :: ScriptName -> IO [ScriptName]
scriptsInDirectory ScriptName
dir =
  ScriptName -> IO [ScriptName]
getDirectoryContents ScriptName
dir forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (forall a. Ord a => [a] -> [a]
sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (\ScriptName
x -> Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ ScriptName
"." forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` ScriptName
x))


-- | Executes a generic SQL migration for the provided script 'name' with content 'contents'.
executeMigration
  :: Connection
  -> MigrationOptions
  -> ScriptName
  -> BS.ByteString
  -> IO (MigrationResult String)
executeMigration :: Connection
-> MigrationOptions
-> ScriptName
-> ByteString
-> IO (MigrationResult ScriptName)
executeMigration Connection
con MigrationOptions
opts ScriptName
name ByteString
contents = forall a. MigrationOptions -> Connection -> IO a -> IO a
doStepTransaction MigrationOptions
opts Connection
con forall a b. (a -> b) -> a -> b
$ do
  let checksum :: ByteString
checksum = ByteString -> ByteString
md5Hash ByteString
contents
  Connection
-> MigrationOptions
-> ScriptName
-> ByteString
-> IO CheckScriptResult
checkScript Connection
con MigrationOptions
opts ScriptName
name ByteString
checksum forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    CheckScriptResult
ScriptOk -> do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MigrationOptions -> Bool
verbose MigrationOptions
opts) forall a b. (a -> b) -> a -> b
$ MigrationOptions -> Either Text Text -> IO ()
optLogWriter MigrationOptions
opts forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Text
"Ok:\t" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => ScriptName -> a
fromString ScriptName
name
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. MigrationResult a
MigrationSuccess
    CheckScriptResult
ScriptNotExecuted -> do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MigrationOptions -> Bool
verbose MigrationOptions
opts) forall a b. (a -> b) -> a -> b
$ MigrationOptions -> Either Text Text -> IO ()
optLogWriter MigrationOptions
opts forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (Text
"Executing:\t" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => ScriptName -> a
fromString ScriptName
name)
      forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Connection -> Query -> IO Int64
execute_ Connection
con (ByteString -> Query
Query ByteString
contents)
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MigrationOptions -> Bool
verbose MigrationOptions
opts) forall a b. (a -> b) -> a -> b
$ MigrationOptions -> Either Text Text -> IO ()
optLogWriter MigrationOptions
opts forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (Text
"Adding '" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => ScriptName -> a
fromString ScriptName
name forall a. Semigroup a => a -> a -> a
<> Text
"' to schema_migrations with checksum '" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => ScriptName -> a
fromString (forall a. Show a => a -> ScriptName
show ByteString
checksum) forall a. Semigroup a => a -> a -> a
<> Text
"'")
      forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall q. ToRow q => Connection -> Query -> q -> IO Int64
execute Connection
con Query
q (ScriptName
name, ByteString
checksum)
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MigrationOptions -> Bool
verbose MigrationOptions
opts) forall a b. (a -> b) -> a -> b
$ MigrationOptions -> Either Text Text -> IO ()
optLogWriter MigrationOptions
opts forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (Text
"Executed:\t" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => ScriptName -> a
fromString ScriptName
name)
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. MigrationResult a
MigrationSuccess
    ScriptModified ExpectedVsActual ByteString
eva -> do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MigrationOptions -> Bool
verbose MigrationOptions
opts) forall a b. (a -> b) -> a -> b
$ MigrationOptions -> Either Text Text -> IO ()
optLogWriter MigrationOptions
opts forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (Text
"Fail:\t" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => ScriptName -> a
fromString ScriptName
name forall a. Semigroup a => a -> a -> a
<> Text
"\n" forall a. Semigroup a => a -> a -> a
<> ExpectedVsActual ByteString -> Text
scriptModifiedErrorMessage ExpectedVsActual ByteString
eva)
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> MigrationResult a
MigrationError ScriptName
name)
  where
    q :: Query
q = Query
"insert into " forall a. Semigroup a => a -> a -> a
<> ByteString -> Query
Query (MigrationOptions -> ByteString
optTableName MigrationOptions
opts) forall a. Semigroup a => a -> a -> a
<> Query
"(filename, checksum) values(?, ?)"

-- | Initializes the database schema with a helper table containing
-- meta-information about executed migrations.
initializeSchema :: Connection -> MigrationOptions -> IO ()
initializeSchema :: Connection -> MigrationOptions -> IO ()
initializeSchema Connection
con MigrationOptions
opts = do
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MigrationOptions -> Bool
verbose MigrationOptions
opts) forall a b. (a -> b) -> a -> b
$ MigrationOptions -> Either Text Text -> IO ()
optLogWriter MigrationOptions
opts forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Text
"Initializing schema"
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. MigrationOptions -> Connection -> IO a -> IO a
doStepTransaction MigrationOptions
opts Connection
con forall b c a. (b -> c) -> (a -> b) -> a -> c
. Connection -> Query -> IO Int64
execute_ Connection
con forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
      [ Query
"create table if not exists " forall a. Semigroup a => a -> a -> a
<> ByteString -> Query
Query (MigrationOptions -> ByteString
optTableName MigrationOptions
opts) forall a. Semigroup a => a -> a -> a
<> Query
" "
      , Query
"( filename varchar(512) not null"
      , Query
", checksum varchar(32) not null"
      , Query
", executed_at timestamp without time zone not null default now() "
      , Query
");"
      ]


-- | Validates a 'MigrationCommand'. Validation is defined as follows for these types:
--
-- * 'MigrationInitialization': validate the presence of the meta-information table.
-- * 'MigrationDirectory': validate the presence and checksum of all scripts found in the given directory.
-- * 'MigrationScript': validate the presence and checksum of the given script.
-- * 'MigrationFile': validate the presence and checksum of the given file.
-- * 'MigrationValidation': always succeeds.
-- * 'MigrationCommands': validates all the sub-commands stopping at the first failure.
executeValidation
  :: Connection
  -> MigrationOptions
  -> MigrationCommand
  -> IO (MigrationResult String)
executeValidation :: Connection
-> MigrationOptions
-> MigrationCommand
-> IO (MigrationResult ScriptName)
executeValidation Connection
con MigrationOptions
opts MigrationCommand
cmd = forall a. MigrationOptions -> Connection -> IO a -> IO a
doStepTransaction MigrationOptions
opts Connection
con forall a b. (a -> b) -> a -> b
$
  case MigrationCommand
cmd of
    MigrationCommand
MigrationInitialization ->
      Connection -> ScriptName -> IO Bool
existsTable Connection
con (ByteString -> ScriptName
BS8.unpack forall a b. (a -> b) -> a -> b
$ MigrationOptions -> ByteString
optTableName MigrationOptions
opts) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
r -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ if Bool
r
        then forall a. MigrationResult a
MigrationSuccess
        else forall a. a -> MigrationResult a
MigrationError (ScriptName
"No such table: " forall a. Semigroup a => a -> a -> a
<> ByteString -> ScriptName
BS8.unpack (MigrationOptions -> ByteString
optTableName MigrationOptions
opts))
    MigrationDirectory ScriptName
path ->
      ScriptName -> IO [ScriptName]
scriptsInDirectory ScriptName
path forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ScriptName -> [ScriptName] -> IO (MigrationResult ScriptName)
goScripts ScriptName
path
    MigrationScript ScriptName
name ByteString
contents ->
      ScriptName -> ByteString -> IO (MigrationResult ScriptName)
validate ScriptName
name ByteString
contents
    MigrationFile ScriptName
name ScriptName
path ->
      ScriptName -> ByteString -> IO (MigrationResult ScriptName)
validate ScriptName
name forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ScriptName -> IO ByteString
BS.readFile ScriptName
path
    MigrationValidation MigrationCommand
_ ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. MigrationResult a
MigrationSuccess
    MigrationCommands [MigrationCommand]
cs ->
      forall (m :: * -> *) e.
Monad m =>
[m (MigrationResult e)] -> m (MigrationResult e)
sequenceMigrations (Connection
-> MigrationOptions
-> MigrationCommand
-> IO (MigrationResult ScriptName)
executeValidation Connection
con MigrationOptions
opts forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MigrationCommand]
cs)
  where
    validate :: ScriptName -> ByteString -> IO (MigrationResult ScriptName)
validate ScriptName
name ByteString
contents =
      Connection
-> MigrationOptions
-> ScriptName
-> ByteString
-> IO CheckScriptResult
checkScript Connection
con MigrationOptions
opts ScriptName
name (ByteString -> ByteString
md5Hash ByteString
contents) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        CheckScriptResult
ScriptOk -> do
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MigrationOptions -> Bool
verbose MigrationOptions
opts) forall a b. (a -> b) -> a -> b
$ MigrationOptions -> Either Text Text -> IO ()
optLogWriter MigrationOptions
opts (forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Text
"Ok:\t" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => ScriptName -> a
fromString ScriptName
name)
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. MigrationResult a
MigrationSuccess
        CheckScriptResult
ScriptNotExecuted -> do
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MigrationOptions -> Bool
verbose MigrationOptions
opts) forall a b. (a -> b) -> a -> b
$ MigrationOptions -> Either Text Text -> IO ()
optLogWriter MigrationOptions
opts (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Missing:\t" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => ScriptName -> a
fromString ScriptName
name)
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> MigrationResult a
MigrationError forall a b. (a -> b) -> a -> b
$ ScriptName
"Missing: " forall a. Semigroup a => a -> a -> a
<> ScriptName
name)
        ScriptModified ExpectedVsActual ByteString
eva -> do
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MigrationOptions -> Bool
verbose MigrationOptions
opts) forall a b. (a -> b) -> a -> b
$ MigrationOptions -> Either Text Text -> IO ()
optLogWriter MigrationOptions
opts (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Checksum mismatch:\t" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => ScriptName -> a
fromString ScriptName
name forall a. Semigroup a => a -> a -> a
<> Text
"\n" forall a. Semigroup a => a -> a -> a
<> ExpectedVsActual ByteString -> Text
scriptModifiedErrorMessage ExpectedVsActual ByteString
eva)
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> MigrationResult a
MigrationError forall a b. (a -> b) -> a -> b
$ ScriptName
"Checksum mismatch: " forall a. Semigroup a => a -> a -> a
<> ScriptName
name)

    goScripts :: ScriptName -> [ScriptName] -> IO (MigrationResult ScriptName)
goScripts ScriptName
path [ScriptName]
xs = forall (m :: * -> *) e.
Monad m =>
[m (MigrationResult e)] -> m (MigrationResult e)
sequenceMigrations (ScriptName -> ScriptName -> IO (MigrationResult ScriptName)
goScript ScriptName
path forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ScriptName]
xs)
    goScript :: ScriptName -> ScriptName -> IO (MigrationResult ScriptName)
goScript ScriptName
path ScriptName
x = ScriptName -> ByteString -> IO (MigrationResult ScriptName)
validate ScriptName
x forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ScriptName -> IO ByteString
BS.readFile (ScriptName
path ScriptName -> ScriptName -> ScriptName
</> ScriptName
x)


-- | Checks the status of the script with the given name 'name'.
-- If the script has already been executed, the checksum of the script
-- is compared against the one that was executed.
-- If there is no matching script entry in the database, the script
-- will be executed and its meta-information will be recorded.
checkScript :: Connection -> MigrationOptions -> ScriptName -> Checksum -> IO CheckScriptResult
checkScript :: Connection
-> MigrationOptions
-> ScriptName
-> ByteString
-> IO CheckScriptResult
checkScript Connection
con MigrationOptions
opts ScriptName
name ByteString
fileChecksum =
  forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
query Connection
con Query
q (forall a. a -> Only a
Only ScriptName
name) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    [] ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure CheckScriptResult
ScriptNotExecuted
    Only ByteString
dbChecksum:[Only ByteString]
_ | ByteString
fileChecksum forall a. Eq a => a -> a -> Bool
== ByteString
dbChecksum ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure CheckScriptResult
ScriptOk
    Only ByteString
dbChecksum:[Only ByteString]
_ ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ExpectedVsActual ByteString -> CheckScriptResult
ScriptModified (ExpectedVsActual {evaExpected :: ByteString
evaExpected = ByteString
dbChecksum, evaActual :: ByteString
evaActual = ByteString
fileChecksum})
  where
    q :: Query
q = forall a. Monoid a => [a] -> a
mconcat
        [ Query
"select checksum from " forall a. Semigroup a => a -> a -> a
<> ByteString -> Query
Query (MigrationOptions -> ByteString
optTableName MigrationOptions
opts) forall a. Semigroup a => a -> a -> a
<> Query
" "
        , Query
"where filename = ? limit 1"
        ]

-- | Calculates the MD5 checksum of the provided bytestring in base64
-- encoding.
md5Hash :: BS.ByteString -> Checksum
md5Hash :: ByteString -> ByteString
md5Hash = ByteString -> ByteString
B64.encode forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
MD5.hash

-- | The checksum type of a migration script.
type Checksum = BS.ByteString

-- | The name of a script. Typically the filename or a custom name
-- when using Haskell migrations.
type ScriptName = String

-- | 'MigrationCommand' determines the action of the 'runMigration' script.
data MigrationCommand
  = MigrationInitialization
  -- ^ Initializes the database with a helper table containing meta
  -- information.
  | MigrationDirectory FilePath
  -- ^ Executes migrations based on SQL scripts in the provided 'FilePath'
  -- in alphabetical order.
  | MigrationFile ScriptName FilePath
  -- ^ Executes a migration based on script located at the provided
  -- 'FilePath'.
  | MigrationScript ScriptName BS.ByteString
  -- ^ Executes a migration based on the provided bytestring.
  | MigrationValidation MigrationCommand
  -- ^ Validates that the provided MigrationCommand has been executed.
  | MigrationCommands [MigrationCommand]
  -- ^ Performs a series of 'MigrationCommand's in sequence.
  deriving (Int -> MigrationCommand -> ScriptName -> ScriptName
[MigrationCommand] -> ScriptName -> ScriptName
MigrationCommand -> ScriptName
forall a.
(Int -> a -> ScriptName -> ScriptName)
-> (a -> ScriptName) -> ([a] -> ScriptName -> ScriptName) -> Show a
showList :: [MigrationCommand] -> ScriptName -> ScriptName
$cshowList :: [MigrationCommand] -> ScriptName -> ScriptName
show :: MigrationCommand -> ScriptName
$cshow :: MigrationCommand -> ScriptName
showsPrec :: Int -> MigrationCommand -> ScriptName -> ScriptName
$cshowsPrec :: Int -> MigrationCommand -> ScriptName -> ScriptName
Show, MigrationCommand -> MigrationCommand -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MigrationCommand -> MigrationCommand -> Bool
$c/= :: MigrationCommand -> MigrationCommand -> Bool
== :: MigrationCommand -> MigrationCommand -> Bool
$c== :: MigrationCommand -> MigrationCommand -> Bool
Eq, ReadPrec [MigrationCommand]
ReadPrec MigrationCommand
Int -> ReadS MigrationCommand
ReadS [MigrationCommand]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [MigrationCommand]
$creadListPrec :: ReadPrec [MigrationCommand]
readPrec :: ReadPrec MigrationCommand
$creadPrec :: ReadPrec MigrationCommand
readList :: ReadS [MigrationCommand]
$creadList :: ReadS [MigrationCommand]
readsPrec :: Int -> ReadS MigrationCommand
$creadsPrec :: Int -> ReadS MigrationCommand
Read, Eq MigrationCommand
MigrationCommand -> MigrationCommand -> Bool
MigrationCommand -> MigrationCommand -> Ordering
MigrationCommand -> MigrationCommand -> MigrationCommand
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: MigrationCommand -> MigrationCommand -> MigrationCommand
$cmin :: MigrationCommand -> MigrationCommand -> MigrationCommand
max :: MigrationCommand -> MigrationCommand -> MigrationCommand
$cmax :: MigrationCommand -> MigrationCommand -> MigrationCommand
>= :: MigrationCommand -> MigrationCommand -> Bool
$c>= :: MigrationCommand -> MigrationCommand -> Bool
> :: MigrationCommand -> MigrationCommand -> Bool
$c> :: MigrationCommand -> MigrationCommand -> Bool
<= :: MigrationCommand -> MigrationCommand -> Bool
$c<= :: MigrationCommand -> MigrationCommand -> Bool
< :: MigrationCommand -> MigrationCommand -> Bool
$c< :: MigrationCommand -> MigrationCommand -> Bool
compare :: MigrationCommand -> MigrationCommand -> Ordering
$ccompare :: MigrationCommand -> MigrationCommand -> Ordering
Ord)

instance Semigroup MigrationCommand where
  <> :: MigrationCommand -> MigrationCommand -> MigrationCommand
(<>) (MigrationCommands [MigrationCommand]
xs) (MigrationCommands [MigrationCommand]
ys) = [MigrationCommand] -> MigrationCommand
MigrationCommands ([MigrationCommand]
xs forall a. Semigroup a => a -> a -> a
<> [MigrationCommand]
ys)
  (<>) (MigrationCommands [MigrationCommand]
xs) MigrationCommand
y = [MigrationCommand] -> MigrationCommand
MigrationCommands ([MigrationCommand]
xs forall a. Semigroup a => a -> a -> a
<> [MigrationCommand
y])
  (<>) MigrationCommand
x (MigrationCommands [MigrationCommand]
ys) = [MigrationCommand] -> MigrationCommand
MigrationCommands (MigrationCommand
x forall a. a -> [a] -> [a]
: [MigrationCommand]
ys)
  (<>) MigrationCommand
x MigrationCommand
y = [MigrationCommand] -> MigrationCommand
MigrationCommands [MigrationCommand
x, MigrationCommand
y]

instance Monoid MigrationCommand where
  mempty :: MigrationCommand
mempty = [MigrationCommand] -> MigrationCommand
MigrationCommands []
  mappend :: MigrationCommand -> MigrationCommand -> MigrationCommand
mappend = forall a. Semigroup a => a -> a -> a
(<>)

data ExpectedVsActual a = ExpectedVsActual
  { forall a. ExpectedVsActual a -> a
evaExpected :: !a
  , forall a. ExpectedVsActual a -> a
evaActual :: !a
  } deriving (Int -> ExpectedVsActual a -> ScriptName -> ScriptName
forall a.
Show a =>
Int -> ExpectedVsActual a -> ScriptName -> ScriptName
forall a.
Show a =>
[ExpectedVsActual a] -> ScriptName -> ScriptName
forall a. Show a => ExpectedVsActual a -> ScriptName
forall a.
(Int -> a -> ScriptName -> ScriptName)
-> (a -> ScriptName) -> ([a] -> ScriptName -> ScriptName) -> Show a
showList :: [ExpectedVsActual a] -> ScriptName -> ScriptName
$cshowList :: forall a.
Show a =>
[ExpectedVsActual a] -> ScriptName -> ScriptName
show :: ExpectedVsActual a -> ScriptName
$cshow :: forall a. Show a => ExpectedVsActual a -> ScriptName
showsPrec :: Int -> ExpectedVsActual a -> ScriptName -> ScriptName
$cshowsPrec :: forall a.
Show a =>
Int -> ExpectedVsActual a -> ScriptName -> ScriptName
Show)

-- | A sum-type denoting the result of a single migration.
data CheckScriptResult
  = ScriptOk
  -- ^ The script has already been executed and the checksums match.
  -- This is good.
  | ScriptModified (ExpectedVsActual Checksum)
  -- ^ The script has already been executed and there is a checksum
  -- mismatch. This is bad.
  | ScriptNotExecuted
  -- ^ The script has not been executed, yet. This is good.
  deriving (Int -> CheckScriptResult -> ScriptName -> ScriptName
[CheckScriptResult] -> ScriptName -> ScriptName
CheckScriptResult -> ScriptName
forall a.
(Int -> a -> ScriptName -> ScriptName)
-> (a -> ScriptName) -> ([a] -> ScriptName -> ScriptName) -> Show a
showList :: [CheckScriptResult] -> ScriptName -> ScriptName
$cshowList :: [CheckScriptResult] -> ScriptName -> ScriptName
show :: CheckScriptResult -> ScriptName
$cshow :: CheckScriptResult -> ScriptName
showsPrec :: Int -> CheckScriptResult -> ScriptName -> ScriptName
$cshowsPrec :: Int -> CheckScriptResult -> ScriptName -> ScriptName
Show)

scriptModifiedErrorMessage :: ExpectedVsActual Checksum -> T.Text
scriptModifiedErrorMessage :: ExpectedVsActual ByteString -> Text
scriptModifiedErrorMessage (ExpectedVsActual ByteString
expected ByteString
actual) =
  Text
"expected: " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => ScriptName -> a
fromString (forall a. Show a => a -> ScriptName
show ByteString
expected) forall a. Semigroup a => a -> a -> a
<> Text
"\nhash was: " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => ScriptName -> a
fromString (forall a. Show a => a -> ScriptName
show ByteString
actual)

-- | A sum-type denoting the result of a migration.
data MigrationResult a
  = MigrationError a
  -- ^ There was an error in script migration.
  | MigrationSuccess
  -- ^ All scripts have been executed successfully.
  deriving (Int -> MigrationResult a -> ScriptName -> ScriptName
forall a.
Show a =>
Int -> MigrationResult a -> ScriptName -> ScriptName
forall a. Show a => [MigrationResult a] -> ScriptName -> ScriptName
forall a. Show a => MigrationResult a -> ScriptName
forall a.
(Int -> a -> ScriptName -> ScriptName)
-> (a -> ScriptName) -> ([a] -> ScriptName -> ScriptName) -> Show a
showList :: [MigrationResult a] -> ScriptName -> ScriptName
$cshowList :: forall a. Show a => [MigrationResult a] -> ScriptName -> ScriptName
show :: MigrationResult a -> ScriptName
$cshow :: forall a. Show a => MigrationResult a -> ScriptName
showsPrec :: Int -> MigrationResult a -> ScriptName -> ScriptName
$cshowsPrec :: forall a.
Show a =>
Int -> MigrationResult a -> ScriptName -> ScriptName
Show, MigrationResult a -> MigrationResult a -> Bool
forall a. Eq a => MigrationResult a -> MigrationResult a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MigrationResult a -> MigrationResult a -> Bool
$c/= :: forall a. Eq a => MigrationResult a -> MigrationResult a -> Bool
== :: MigrationResult a -> MigrationResult a -> Bool
$c== :: forall a. Eq a => MigrationResult a -> MigrationResult a -> Bool
Eq, ReadPrec [MigrationResult a]
ReadPrec (MigrationResult a)
ReadS [MigrationResult a]
forall a. Read a => ReadPrec [MigrationResult a]
forall a. Read a => ReadPrec (MigrationResult a)
forall a. Read a => Int -> ReadS (MigrationResult a)
forall a. Read a => ReadS [MigrationResult a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [MigrationResult a]
$creadListPrec :: forall a. Read a => ReadPrec [MigrationResult a]
readPrec :: ReadPrec (MigrationResult a)
$creadPrec :: forall a. Read a => ReadPrec (MigrationResult a)
readList :: ReadS [MigrationResult a]
$creadList :: forall a. Read a => ReadS [MigrationResult a]
readsPrec :: Int -> ReadS (MigrationResult a)
$creadsPrec :: forall a. Read a => Int -> ReadS (MigrationResult a)
Read, MigrationResult a -> MigrationResult a -> Bool
MigrationResult a -> MigrationResult a -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (MigrationResult a)
forall a. Ord a => MigrationResult a -> MigrationResult a -> Bool
forall a.
Ord a =>
MigrationResult a -> MigrationResult a -> Ordering
forall a.
Ord a =>
MigrationResult a -> MigrationResult a -> MigrationResult a
min :: MigrationResult a -> MigrationResult a -> MigrationResult a
$cmin :: forall a.
Ord a =>
MigrationResult a -> MigrationResult a -> MigrationResult a
max :: MigrationResult a -> MigrationResult a -> MigrationResult a
$cmax :: forall a.
Ord a =>
MigrationResult a -> MigrationResult a -> MigrationResult a
>= :: MigrationResult a -> MigrationResult a -> Bool
$c>= :: forall a. Ord a => MigrationResult a -> MigrationResult a -> Bool
> :: MigrationResult a -> MigrationResult a -> Bool
$c> :: forall a. Ord a => MigrationResult a -> MigrationResult a -> Bool
<= :: MigrationResult a -> MigrationResult a -> Bool
$c<= :: forall a. Ord a => MigrationResult a -> MigrationResult a -> Bool
< :: MigrationResult a -> MigrationResult a -> Bool
$c< :: forall a. Ord a => MigrationResult a -> MigrationResult a -> Bool
compare :: MigrationResult a -> MigrationResult a -> Ordering
$ccompare :: forall a.
Ord a =>
MigrationResult a -> MigrationResult a -> Ordering
Ord, forall a b. a -> MigrationResult b -> MigrationResult a
forall a b. (a -> b) -> MigrationResult a -> MigrationResult b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> MigrationResult b -> MigrationResult a
$c<$ :: forall a b. a -> MigrationResult b -> MigrationResult a
fmap :: forall a b. (a -> b) -> MigrationResult a -> MigrationResult b
$cfmap :: forall a b. (a -> b) -> MigrationResult a -> MigrationResult b
Functor, forall a. Eq a => a -> MigrationResult a -> Bool
forall a. Num a => MigrationResult a -> a
forall a. Ord a => MigrationResult a -> a
forall m. Monoid m => MigrationResult m -> m
forall a. MigrationResult a -> Bool
forall a. MigrationResult a -> Int
forall a. MigrationResult a -> [a]
forall a. (a -> a -> a) -> MigrationResult a -> a
forall m a. Monoid m => (a -> m) -> MigrationResult a -> m
forall b a. (b -> a -> b) -> b -> MigrationResult a -> b
forall a b. (a -> b -> b) -> b -> MigrationResult a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => MigrationResult a -> a
$cproduct :: forall a. Num a => MigrationResult a -> a
sum :: forall a. Num a => MigrationResult a -> a
$csum :: forall a. Num a => MigrationResult a -> a
minimum :: forall a. Ord a => MigrationResult a -> a
$cminimum :: forall a. Ord a => MigrationResult a -> a
maximum :: forall a. Ord a => MigrationResult a -> a
$cmaximum :: forall a. Ord a => MigrationResult a -> a
elem :: forall a. Eq a => a -> MigrationResult a -> Bool
$celem :: forall a. Eq a => a -> MigrationResult a -> Bool
length :: forall a. MigrationResult a -> Int
$clength :: forall a. MigrationResult a -> Int
null :: forall a. MigrationResult a -> Bool
$cnull :: forall a. MigrationResult a -> Bool
toList :: forall a. MigrationResult a -> [a]
$ctoList :: forall a. MigrationResult a -> [a]
foldl1 :: forall a. (a -> a -> a) -> MigrationResult a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> MigrationResult a -> a
foldr1 :: forall a. (a -> a -> a) -> MigrationResult a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> MigrationResult a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> MigrationResult a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> MigrationResult a -> b
foldl :: forall b a. (b -> a -> b) -> b -> MigrationResult a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> MigrationResult a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> MigrationResult a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> MigrationResult a -> b
foldr :: forall a b. (a -> b -> b) -> b -> MigrationResult a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> MigrationResult a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> MigrationResult a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> MigrationResult a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> MigrationResult a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> MigrationResult a -> m
fold :: forall m. Monoid m => MigrationResult m -> m
$cfold :: forall m. Monoid m => MigrationResult m -> m
Foldable, Functor MigrationResult
Foldable MigrationResult
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
MigrationResult (m a) -> m (MigrationResult a)
forall (f :: * -> *) a.
Applicative f =>
MigrationResult (f a) -> f (MigrationResult a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> MigrationResult a -> m (MigrationResult b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> MigrationResult a -> f (MigrationResult b)
sequence :: forall (m :: * -> *) a.
Monad m =>
MigrationResult (m a) -> m (MigrationResult a)
$csequence :: forall (m :: * -> *) a.
Monad m =>
MigrationResult (m a) -> m (MigrationResult a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> MigrationResult a -> m (MigrationResult b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> MigrationResult a -> m (MigrationResult b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
MigrationResult (f a) -> f (MigrationResult a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
MigrationResult (f a) -> f (MigrationResult a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> MigrationResult a -> f (MigrationResult b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> MigrationResult a -> f (MigrationResult b)
Traversable)

data Verbosity
  = Verbose
  | Quiet
  deriving (Int -> Verbosity -> ScriptName -> ScriptName
[Verbosity] -> ScriptName -> ScriptName
Verbosity -> ScriptName
forall a.
(Int -> a -> ScriptName -> ScriptName)
-> (a -> ScriptName) -> ([a] -> ScriptName -> ScriptName) -> Show a
showList :: [Verbosity] -> ScriptName -> ScriptName
$cshowList :: [Verbosity] -> ScriptName -> ScriptName
show :: Verbosity -> ScriptName
$cshow :: Verbosity -> ScriptName
showsPrec :: Int -> Verbosity -> ScriptName -> ScriptName
$cshowsPrec :: Int -> Verbosity -> ScriptName -> ScriptName
Show, Verbosity -> Verbosity -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Verbosity -> Verbosity -> Bool
$c/= :: Verbosity -> Verbosity -> Bool
== :: Verbosity -> Verbosity -> Bool
$c== :: Verbosity -> Verbosity -> Bool
Eq)

-- | Determines how transactions are handled
-- Its is recommened to use transaction when running migrations
-- Certain actions require a transaction per script, if you are doing this use TransactionPerStep
-- If you want a single transaction for all migrations use TransactionPerRun
-- If you do not want a transaction, or are using an existing transaction then use NoNewTransaction
data TransactionControl
  = NoNewTransaction -- ^ No new transaction will be started. Up to the caller to decide if the run is in a transaction or not
  | TransactionPerRun -- ^ Call 'withTransaction' once for the entire 'MigrationCommand'
  | TransactionPerStep -- ^ Call 'withTransaction' once for each step in a 'MigrationCommand' (i.e. new transaction per script)
  deriving (Int -> TransactionControl -> ScriptName -> ScriptName
[TransactionControl] -> ScriptName -> ScriptName
TransactionControl -> ScriptName
forall a.
(Int -> a -> ScriptName -> ScriptName)
-> (a -> ScriptName) -> ([a] -> ScriptName -> ScriptName) -> Show a
showList :: [TransactionControl] -> ScriptName -> ScriptName
$cshowList :: [TransactionControl] -> ScriptName -> ScriptName
show :: TransactionControl -> ScriptName
$cshow :: TransactionControl -> ScriptName
showsPrec :: Int -> TransactionControl -> ScriptName -> ScriptName
$cshowsPrec :: Int -> TransactionControl -> ScriptName -> ScriptName
Show)


data MigrationOptions = MigrationOptions
  { MigrationOptions -> Verbosity
optVerbose :: !Verbosity
  -- ^ Verbosity of the library.
  , MigrationOptions -> ByteString
optTableName :: !BS.ByteString
  -- ^ The name of the table that stores the migrations, usually "schema_migrations"
  , MigrationOptions -> Either Text Text -> IO ()
optLogWriter :: !(Either T.Text T.Text -> IO ())
  -- ^ Logger. 'Either' indicates log level,
  -- 'Left' for an error message and 'Right' for an info message.
  , MigrationOptions -> TransactionControl
optTransactionControl :: !TransactionControl
  -- ^ If/when transactions should be started
  }

defaultOptions :: MigrationOptions
defaultOptions :: MigrationOptions
defaultOptions =
  MigrationOptions
    { optVerbose :: Verbosity
optVerbose = Verbosity
Quiet
    , optTableName :: ByteString
optTableName = ByteString
"schema_migrations"
    , optLogWriter :: Either Text Text -> IO ()
optLogWriter = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr) Text -> IO ()
T.putStrLn
    , optTransactionControl :: TransactionControl
optTransactionControl = TransactionControl
TransactionPerRun
    }

verbose :: MigrationOptions -> Bool
verbose :: MigrationOptions -> Bool
verbose MigrationOptions
o = MigrationOptions -> Verbosity
optVerbose MigrationOptions
o forall a. Eq a => a -> a -> Bool
== Verbosity
Verbose


doRunTransaction :: MigrationOptions -> Connection -> IO a -> IO a
doRunTransaction :: forall a. MigrationOptions -> Connection -> IO a -> IO a
doRunTransaction MigrationOptions
opts Connection
con IO a
act =
  case MigrationOptions -> TransactionControl
optTransactionControl MigrationOptions
opts of
    TransactionControl
NoNewTransaction -> IO a
act
    TransactionControl
TransactionPerRun -> forall a. Connection -> IO a -> IO a
withTransaction Connection
con IO a
act
    TransactionControl
TransactionPerStep -> IO a
act


doStepTransaction :: MigrationOptions -> Connection -> IO a -> IO a
doStepTransaction :: forall a. MigrationOptions -> Connection -> IO a -> IO a
doStepTransaction MigrationOptions
opts Connection
con IO a
act =
  case MigrationOptions -> TransactionControl
optTransactionControl MigrationOptions
opts of
    TransactionControl
NoNewTransaction -> IO a
act
    TransactionControl
TransactionPerRun -> IO a
act
    TransactionControl
TransactionPerStep -> forall a. Connection -> IO a -> IO a
withTransaction Connection
con IO a
act


-- | Produces a list of all executed 'SchemaMigration's in the default schema_migrations table
getMigrations :: Connection -> IO [SchemaMigration]
getMigrations :: Connection -> IO [SchemaMigration]
getMigrations Connection
con = Connection -> ByteString -> IO [SchemaMigration]
getMigrations' Connection
con ByteString
"schema_migrations"

-- | Produces a list of all executed 'SchemaMigration's.
getMigrations' :: Connection -> BS.ByteString -> IO [SchemaMigration]
getMigrations' :: Connection -> ByteString -> IO [SchemaMigration]
getMigrations' Connection
con ByteString
tableName = forall r. FromRow r => Connection -> Query -> IO [r]
query_ Connection
con Query
q
  where q :: Query
q = forall a. Monoid a => [a] -> a
mconcat
          [ Query
"select filename, checksum, executed_at "
          , Query
"from " forall a. Semigroup a => a -> a -> a
<> ByteString -> Query
Query ByteString
tableName forall a. Semigroup a => a -> a -> a
<> Query
" order by executed_at asc"
          ]

-- | A product type representing a single, executed 'SchemaMigration'.
data SchemaMigration = SchemaMigration
  { SchemaMigration -> ByteString
schemaMigrationName       :: BS.ByteString
  -- ^ The name of the executed migration.
  , SchemaMigration -> ByteString
schemaMigrationChecksum   :: Checksum
  -- ^ The calculated MD5 checksum of the executed script.
  , SchemaMigration -> LocalTime
schemaMigrationExecutedAt :: LocalTime
  -- ^ A timestamp without timezone of the date of execution of the script.
  } deriving (Int -> SchemaMigration -> ScriptName -> ScriptName
[SchemaMigration] -> ScriptName -> ScriptName
SchemaMigration -> ScriptName
forall a.
(Int -> a -> ScriptName -> ScriptName)
-> (a -> ScriptName) -> ([a] -> ScriptName -> ScriptName) -> Show a
showList :: [SchemaMigration] -> ScriptName -> ScriptName
$cshowList :: [SchemaMigration] -> ScriptName -> ScriptName
show :: SchemaMigration -> ScriptName
$cshow :: SchemaMigration -> ScriptName
showsPrec :: Int -> SchemaMigration -> ScriptName -> ScriptName
$cshowsPrec :: Int -> SchemaMigration -> ScriptName -> ScriptName
Show, SchemaMigration -> SchemaMigration -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SchemaMigration -> SchemaMigration -> Bool
$c/= :: SchemaMigration -> SchemaMigration -> Bool
== :: SchemaMigration -> SchemaMigration -> Bool
$c== :: SchemaMigration -> SchemaMigration -> Bool
Eq, ReadPrec [SchemaMigration]
ReadPrec SchemaMigration
Int -> ReadS SchemaMigration
ReadS [SchemaMigration]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [SchemaMigration]
$creadListPrec :: ReadPrec [SchemaMigration]
readPrec :: ReadPrec SchemaMigration
$creadPrec :: ReadPrec SchemaMigration
readList :: ReadS [SchemaMigration]
$creadList :: ReadS [SchemaMigration]
readsPrec :: Int -> ReadS SchemaMigration
$creadsPrec :: Int -> ReadS SchemaMigration
Read)

instance Ord SchemaMigration where
  compare :: SchemaMigration -> SchemaMigration -> Ordering
compare (SchemaMigration ByteString
nameLeft ByteString
_ LocalTime
_) (SchemaMigration ByteString
nameRight ByteString
_ LocalTime
_) =
    forall a. Ord a => a -> a -> Ordering
compare ByteString
nameLeft ByteString
nameRight

instance FromRow SchemaMigration where
  fromRow :: RowParser SchemaMigration
fromRow = ByteString -> ByteString -> LocalTime -> SchemaMigration
SchemaMigration forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    forall a. FromField a => RowParser a
field forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. FromField a => RowParser a
field forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. FromField a => RowParser a
field

instance ToRow SchemaMigration where
  toRow :: SchemaMigration -> [Action]
toRow (SchemaMigration ByteString
name ByteString
checksum LocalTime
executedAt) =
   [forall a. ToField a => a -> Action
toField ByteString
name, forall a. ToField a => a -> Action
toField ByteString
checksum, forall a. ToField a => a -> Action
toField LocalTime
executedAt]