-- |
-- 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 (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 (listDirectory)
import           System.FilePath ((</>))
import           System.IO (stderr)

-- | Executes migrations using the provided 'MigrationOptions'.
--
-- 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 IO ()
-> IO (MigrationResult ScriptName)
-> IO (MigrationResult ScriptName)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MigrationResult ScriptName -> IO (MigrationResult ScriptName)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MigrationResult ScriptName
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 (ByteString -> IO (MigrationResult ScriptName))
-> IO ByteString -> IO (MigrationResult ScriptName)
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 MigrationOptions
-> Connection
-> IO (MigrationResult ScriptName)
-> IO (MigrationResult ScriptName)
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 = [IO (MigrationResult ScriptName)]
-> IO (MigrationResult ScriptName)
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
  [] -> MigrationResult e -> m (MigrationResult e)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MigrationResult e
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 -> MigrationResult e -> m (MigrationResult e)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (e -> MigrationResult e
forall a. a -> MigrationResult a
MigrationError e
s)
      MigrationResult e
MigrationSuccess -> [m (MigrationResult e)] -> m (MigrationResult e)
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 IO [ScriptName]
-> ([ScriptName] -> IO (MigrationResult ScriptName))
-> IO (MigrationResult ScriptName)
forall a b. IO a -> (a -> IO b) -> IO b
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 = [IO (MigrationResult ScriptName)]
-> IO (MigrationResult ScriptName)
forall (m :: * -> *) e.
Monad m =>
[m (MigrationResult e)] -> m (MigrationResult e)
sequenceMigrations (ScriptName -> IO (MigrationResult ScriptName)
executeMigrationFile (ScriptName -> IO (MigrationResult ScriptName))
-> [ScriptName] -> [IO (MigrationResult ScriptName)]
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) IO ByteString
-> (ByteString -> IO (MigrationResult ScriptName))
-> IO (MigrationResult ScriptName)
forall a b. IO a -> (a -> IO b) -> IO b
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] -> [ScriptName]
forall a. Ord a => [a] -> [a]
sort ([ScriptName] -> [ScriptName])
-> IO [ScriptName] -> IO [ScriptName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ScriptName -> IO [ScriptName]
listDirectory ScriptName
dir


-- | 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 = MigrationOptions
-> Connection
-> IO (MigrationResult ScriptName)
-> IO (MigrationResult ScriptName)
forall a. MigrationOptions -> Connection -> IO a -> IO a
doStepTransaction MigrationOptions
opts Connection
con (IO (MigrationResult ScriptName)
 -> IO (MigrationResult ScriptName))
-> IO (MigrationResult ScriptName)
-> IO (MigrationResult ScriptName)
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 IO CheckScriptResult
-> (CheckScriptResult -> IO (MigrationResult ScriptName))
-> IO (MigrationResult ScriptName)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    CheckScriptResult
ScriptOk -> do
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MigrationOptions -> Bool
verbose MigrationOptions
opts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MigrationOptions -> Either Text Text -> IO ()
optLogWriter MigrationOptions
opts (Either Text Text -> IO ()) -> Either Text Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Either Text Text
forall a b. b -> Either a b
Right (Text -> Either Text Text) -> Text -> Either Text Text
forall a b. (a -> b) -> a -> b
$ Text
"Ok:\t" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ScriptName -> Text
forall a. IsString a => ScriptName -> a
fromString ScriptName
name
      MigrationResult ScriptName -> IO (MigrationResult ScriptName)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MigrationResult ScriptName
forall a. MigrationResult a
MigrationSuccess
    CheckScriptResult
ScriptNotExecuted -> do
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MigrationOptions -> Bool
verbose MigrationOptions
opts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MigrationOptions -> Either Text Text -> IO ()
optLogWriter MigrationOptions
opts (Either Text Text -> IO ()) -> Either Text Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Either Text Text
forall a b. b -> Either a b
Right (Text
"Executing:\t" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ScriptName -> Text
forall a. IsString a => ScriptName -> a
fromString ScriptName
name)
      IO Int64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int64 -> IO ()) -> IO Int64 -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> Query -> IO Int64
execute_ Connection
con (ByteString -> Query
Query ByteString
contents)
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MigrationOptions -> Bool
verbose MigrationOptions
opts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MigrationOptions -> Either Text Text -> IO ()
optLogWriter MigrationOptions
opts (Either Text Text -> IO ()) -> Either Text Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Either Text Text
forall a b. b -> Either a b
Right (Text
"Adding '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ScriptName -> Text
forall a. IsString a => ScriptName -> a
fromString ScriptName
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' to schema_migrations with checksum '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ScriptName -> Text
forall a. IsString a => ScriptName -> a
fromString (ByteString -> ScriptName
forall a. Show a => a -> ScriptName
show ByteString
checksum) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'")
      IO Int64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int64 -> IO ()) -> IO Int64 -> IO ()
forall a b. (a -> b) -> a -> b
$ Connection -> Query -> (ScriptName, ByteString) -> IO Int64
forall q. ToRow q => Connection -> Query -> q -> IO Int64
execute Connection
con Query
q (ScriptName
name, ByteString
checksum)
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MigrationOptions -> Bool
verbose MigrationOptions
opts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MigrationOptions -> Either Text Text -> IO ()
optLogWriter MigrationOptions
opts (Either Text Text -> IO ()) -> Either Text Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Either Text Text
forall a b. b -> Either a b
Right (Text
"Executed:\t" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ScriptName -> Text
forall a. IsString a => ScriptName -> a
fromString ScriptName
name)
      MigrationResult ScriptName -> IO (MigrationResult ScriptName)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MigrationResult ScriptName
forall a. MigrationResult a
MigrationSuccess
    ScriptModified ExpectedVsActual ByteString
eva -> do
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MigrationOptions -> Bool
verbose MigrationOptions
opts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MigrationOptions -> Either Text Text -> IO ()
optLogWriter MigrationOptions
opts (Either Text Text -> IO ()) -> Either Text Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Either Text Text
forall a b. a -> Either a b
Left (Text
"Fail:\t" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ScriptName -> Text
forall a. IsString a => ScriptName -> a
fromString ScriptName
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ExpectedVsActual ByteString -> Text
scriptModifiedErrorMessage ExpectedVsActual ByteString
eva)
      MigrationResult ScriptName -> IO (MigrationResult ScriptName)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ScriptName -> MigrationResult ScriptName
forall a. a -> MigrationResult a
MigrationError ScriptName
name)
  where
    q :: Query
q = Query
"insert into " Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> ByteString -> Query
Query (MigrationOptions -> ByteString
optTableName MigrationOptions
opts) Query -> Query -> Query
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
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MigrationOptions -> Bool
verbose MigrationOptions
opts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MigrationOptions -> Either Text Text -> IO ()
optLogWriter MigrationOptions
opts (Either Text Text -> IO ()) -> Either Text Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Either Text Text
forall a b. b -> Either a b
Right Text
"Initializing schema"
  IO Int64 -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int64 -> IO ()) -> (Query -> IO Int64) -> Query -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MigrationOptions -> Connection -> IO Int64 -> IO Int64
forall a. MigrationOptions -> Connection -> IO a -> IO a
doStepTransaction MigrationOptions
opts Connection
con (IO Int64 -> IO Int64) -> (Query -> IO Int64) -> Query -> IO Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Connection -> Query -> IO Int64
execute_ Connection
con (Query -> IO ()) -> Query -> IO ()
forall a b. (a -> b) -> a -> b
$ [Query] -> Query
forall a. Monoid a => [a] -> a
mconcat
      [ Query
"create table if not exists " Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> ByteString -> Query
Query (MigrationOptions -> ByteString
optTableName MigrationOptions
opts) Query -> Query -> Query
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 = MigrationOptions
-> Connection
-> IO (MigrationResult ScriptName)
-> IO (MigrationResult ScriptName)
forall a. MigrationOptions -> Connection -> IO a -> IO a
doStepTransaction MigrationOptions
opts Connection
con (IO (MigrationResult ScriptName)
 -> IO (MigrationResult ScriptName))
-> IO (MigrationResult ScriptName)
-> IO (MigrationResult ScriptName)
forall a b. (a -> b) -> a -> b
$
  case MigrationCommand
cmd of
    MigrationCommand
MigrationInitialization ->
      Connection -> ScriptName -> IO Bool
existsTable Connection
con (ByteString -> ScriptName
BS8.unpack (ByteString -> ScriptName) -> ByteString -> ScriptName
forall a b. (a -> b) -> a -> b
$ MigrationOptions -> ByteString
optTableName MigrationOptions
opts) IO Bool
-> (Bool -> MigrationResult ScriptName)
-> IO (MigrationResult ScriptName)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Bool
r -> if Bool
r
        then MigrationResult ScriptName
forall a. MigrationResult a
MigrationSuccess
        else ScriptName -> MigrationResult ScriptName
forall a. a -> MigrationResult a
MigrationError (ScriptName
"No such table: " ScriptName -> ScriptName -> ScriptName
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 IO [ScriptName]
-> ([ScriptName] -> IO (MigrationResult ScriptName))
-> IO (MigrationResult ScriptName)
forall a b. IO a -> (a -> IO b) -> IO b
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 (ByteString -> IO (MigrationResult ScriptName))
-> IO ByteString -> IO (MigrationResult ScriptName)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ScriptName -> IO ByteString
BS.readFile ScriptName
path
    MigrationValidation MigrationCommand
_ ->
      MigrationResult ScriptName -> IO (MigrationResult ScriptName)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MigrationResult ScriptName
forall a. MigrationResult a
MigrationSuccess
    MigrationCommands [MigrationCommand]
cs ->
      [IO (MigrationResult ScriptName)]
-> IO (MigrationResult ScriptName)
forall (m :: * -> *) e.
Monad m =>
[m (MigrationResult e)] -> m (MigrationResult e)
sequenceMigrations (Connection
-> MigrationOptions
-> MigrationCommand
-> IO (MigrationResult ScriptName)
executeValidation Connection
con MigrationOptions
opts (MigrationCommand -> IO (MigrationResult ScriptName))
-> [MigrationCommand] -> [IO (MigrationResult ScriptName)]
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) IO CheckScriptResult
-> (CheckScriptResult -> IO (MigrationResult ScriptName))
-> IO (MigrationResult ScriptName)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        CheckScriptResult
ScriptOk -> do
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MigrationOptions -> Bool
verbose MigrationOptions
opts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MigrationOptions -> Either Text Text -> IO ()
optLogWriter MigrationOptions
opts (Text -> Either Text Text
forall a b. b -> Either a b
Right (Text -> Either Text Text) -> Text -> Either Text Text
forall a b. (a -> b) -> a -> b
$ Text
"Ok:\t" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ScriptName -> Text
forall a. IsString a => ScriptName -> a
fromString ScriptName
name)
          MigrationResult ScriptName -> IO (MigrationResult ScriptName)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MigrationResult ScriptName
forall a. MigrationResult a
MigrationSuccess
        CheckScriptResult
ScriptNotExecuted -> do
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MigrationOptions -> Bool
verbose MigrationOptions
opts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MigrationOptions -> Either Text Text -> IO ()
optLogWriter MigrationOptions
opts (Text -> Either Text Text
forall a b. a -> Either a b
Left (Text -> Either Text Text) -> Text -> Either Text Text
forall a b. (a -> b) -> a -> b
$ Text
"Missing:\t" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ScriptName -> Text
forall a. IsString a => ScriptName -> a
fromString ScriptName
name)
          MigrationResult ScriptName -> IO (MigrationResult ScriptName)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ScriptName -> MigrationResult ScriptName
forall a. a -> MigrationResult a
MigrationError (ScriptName -> MigrationResult ScriptName)
-> ScriptName -> MigrationResult ScriptName
forall a b. (a -> b) -> a -> b
$ ScriptName
"Missing: " ScriptName -> ScriptName -> ScriptName
forall a. Semigroup a => a -> a -> a
<> ScriptName
name)
        ScriptModified ExpectedVsActual ByteString
eva -> do
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MigrationOptions -> Bool
verbose MigrationOptions
opts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ MigrationOptions -> Either Text Text -> IO ()
optLogWriter MigrationOptions
opts (Text -> Either Text Text
forall a b. a -> Either a b
Left (Text -> Either Text Text) -> Text -> Either Text Text
forall a b. (a -> b) -> a -> b
$ Text
"Checksum mismatch:\t" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ScriptName -> Text
forall a. IsString a => ScriptName -> a
fromString ScriptName
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ExpectedVsActual ByteString -> Text
scriptModifiedErrorMessage ExpectedVsActual ByteString
eva)
          MigrationResult ScriptName -> IO (MigrationResult ScriptName)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ScriptName -> MigrationResult ScriptName
forall a. a -> MigrationResult a
MigrationError (ScriptName -> MigrationResult ScriptName)
-> ScriptName -> MigrationResult ScriptName
forall a b. (a -> b) -> a -> b
$ ScriptName
"Checksum mismatch: " ScriptName -> ScriptName -> ScriptName
forall a. Semigroup a => a -> a -> a
<> ScriptName
name)

    goScripts :: ScriptName -> [ScriptName] -> IO (MigrationResult ScriptName)
goScripts ScriptName
path [ScriptName]
xs = [IO (MigrationResult ScriptName)]
-> IO (MigrationResult ScriptName)
forall (m :: * -> *) e.
Monad m =>
[m (MigrationResult e)] -> m (MigrationResult e)
sequenceMigrations (ScriptName -> ScriptName -> IO (MigrationResult ScriptName)
goScript ScriptName
path (ScriptName -> IO (MigrationResult ScriptName))
-> [ScriptName] -> [IO (MigrationResult ScriptName)]
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 (ByteString -> IO (MigrationResult ScriptName))
-> IO ByteString -> IO (MigrationResult ScriptName)
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 =
  Connection -> Query -> Only ScriptName -> IO [Only ByteString]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
query Connection
con Query
q (ScriptName -> Only ScriptName
forall a. a -> Only a
Only ScriptName
name) IO [Only ByteString]
-> ([Only ByteString] -> IO CheckScriptResult)
-> IO CheckScriptResult
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    [] ->
      CheckScriptResult -> IO CheckScriptResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CheckScriptResult
ScriptNotExecuted
    Only ByteString
dbChecksum:[Only ByteString]
_ | ByteString
fileChecksum ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
dbChecksum ->
      CheckScriptResult -> IO CheckScriptResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CheckScriptResult
ScriptOk
    Only ByteString
dbChecksum:[Only ByteString]
_ ->
      CheckScriptResult -> IO CheckScriptResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CheckScriptResult -> IO CheckScriptResult)
-> CheckScriptResult -> IO CheckScriptResult
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 = [Query] -> Query
forall a. Monoid a => [a] -> a
mconcat
        [ Query
"select checksum from " Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> ByteString -> Query
Query (MigrationOptions -> ByteString
optTableName MigrationOptions
opts) Query -> Query -> Query
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 (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
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
(Int -> MigrationCommand -> ScriptName -> ScriptName)
-> (MigrationCommand -> ScriptName)
-> ([MigrationCommand] -> ScriptName -> ScriptName)
-> Show MigrationCommand
forall a.
(Int -> a -> ScriptName -> ScriptName)
-> (a -> ScriptName) -> ([a] -> ScriptName -> ScriptName) -> Show a
$cshowsPrec :: Int -> MigrationCommand -> ScriptName -> ScriptName
showsPrec :: Int -> MigrationCommand -> ScriptName -> ScriptName
$cshow :: MigrationCommand -> ScriptName
show :: MigrationCommand -> ScriptName
$cshowList :: [MigrationCommand] -> ScriptName -> ScriptName
showList :: [MigrationCommand] -> ScriptName -> ScriptName
Show, MigrationCommand -> MigrationCommand -> Bool
(MigrationCommand -> MigrationCommand -> Bool)
-> (MigrationCommand -> MigrationCommand -> Bool)
-> Eq MigrationCommand
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MigrationCommand -> MigrationCommand -> Bool
== :: MigrationCommand -> MigrationCommand -> Bool
$c/= :: MigrationCommand -> MigrationCommand -> Bool
/= :: MigrationCommand -> MigrationCommand -> Bool
Eq, ReadPrec [MigrationCommand]
ReadPrec MigrationCommand
Int -> ReadS MigrationCommand
ReadS [MigrationCommand]
(Int -> ReadS MigrationCommand)
-> ReadS [MigrationCommand]
-> ReadPrec MigrationCommand
-> ReadPrec [MigrationCommand]
-> Read MigrationCommand
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS MigrationCommand
readsPrec :: Int -> ReadS MigrationCommand
$creadList :: ReadS [MigrationCommand]
readList :: ReadS [MigrationCommand]
$creadPrec :: ReadPrec MigrationCommand
readPrec :: ReadPrec MigrationCommand
$creadListPrec :: ReadPrec [MigrationCommand]
readListPrec :: ReadPrec [MigrationCommand]
Read, Eq MigrationCommand
Eq MigrationCommand =>
(MigrationCommand -> MigrationCommand -> Ordering)
-> (MigrationCommand -> MigrationCommand -> Bool)
-> (MigrationCommand -> MigrationCommand -> Bool)
-> (MigrationCommand -> MigrationCommand -> Bool)
-> (MigrationCommand -> MigrationCommand -> Bool)
-> (MigrationCommand -> MigrationCommand -> MigrationCommand)
-> (MigrationCommand -> MigrationCommand -> MigrationCommand)
-> Ord 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
$ccompare :: MigrationCommand -> MigrationCommand -> Ordering
compare :: MigrationCommand -> MigrationCommand -> Ordering
$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
>= :: MigrationCommand -> MigrationCommand -> Bool
$cmax :: MigrationCommand -> MigrationCommand -> MigrationCommand
max :: MigrationCommand -> MigrationCommand -> MigrationCommand
$cmin :: MigrationCommand -> MigrationCommand -> MigrationCommand
min :: MigrationCommand -> MigrationCommand -> MigrationCommand
Ord)

instance Semigroup MigrationCommand where
  <> :: MigrationCommand -> MigrationCommand -> MigrationCommand
(<>) (MigrationCommands [MigrationCommand]
xs) (MigrationCommands [MigrationCommand]
ys) = [MigrationCommand] -> MigrationCommand
MigrationCommands ([MigrationCommand]
xs [MigrationCommand] -> [MigrationCommand] -> [MigrationCommand]
forall a. Semigroup a => a -> a -> a
<> [MigrationCommand]
ys)
  (<>) (MigrationCommands [MigrationCommand]
xs) MigrationCommand
y = [MigrationCommand] -> MigrationCommand
MigrationCommands ([MigrationCommand]
xs [MigrationCommand] -> [MigrationCommand] -> [MigrationCommand]
forall a. Semigroup a => a -> a -> a
<> [MigrationCommand
y])
  (<>) MigrationCommand
x (MigrationCommands [MigrationCommand]
ys) = [MigrationCommand] -> MigrationCommand
MigrationCommands (MigrationCommand
x MigrationCommand -> [MigrationCommand] -> [MigrationCommand]
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 = MigrationCommand -> MigrationCommand -> MigrationCommand
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
[ExpectedVsActual a] -> ScriptName -> ScriptName
ExpectedVsActual a -> ScriptName
(Int -> ExpectedVsActual a -> ScriptName -> ScriptName)
-> (ExpectedVsActual a -> ScriptName)
-> ([ExpectedVsActual a] -> ScriptName -> ScriptName)
-> Show (ExpectedVsActual a)
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
$cshowsPrec :: forall a.
Show a =>
Int -> ExpectedVsActual a -> ScriptName -> ScriptName
showsPrec :: Int -> ExpectedVsActual a -> ScriptName -> ScriptName
$cshow :: forall a. Show a => ExpectedVsActual a -> ScriptName
show :: ExpectedVsActual a -> ScriptName
$cshowList :: forall a.
Show a =>
[ExpectedVsActual a] -> ScriptName -> ScriptName
showList :: [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
(Int -> CheckScriptResult -> ScriptName -> ScriptName)
-> (CheckScriptResult -> ScriptName)
-> ([CheckScriptResult] -> ScriptName -> ScriptName)
-> Show CheckScriptResult
forall a.
(Int -> a -> ScriptName -> ScriptName)
-> (a -> ScriptName) -> ([a] -> ScriptName -> ScriptName) -> Show a
$cshowsPrec :: Int -> CheckScriptResult -> ScriptName -> ScriptName
showsPrec :: Int -> CheckScriptResult -> ScriptName -> ScriptName
$cshow :: CheckScriptResult -> ScriptName
show :: CheckScriptResult -> ScriptName
$cshowList :: [CheckScriptResult] -> ScriptName -> ScriptName
showList :: [CheckScriptResult] -> ScriptName -> ScriptName
Show)

scriptModifiedErrorMessage :: ExpectedVsActual Checksum -> T.Text
scriptModifiedErrorMessage :: ExpectedVsActual ByteString -> Text
scriptModifiedErrorMessage (ExpectedVsActual ByteString
expected ByteString
actual) =
  Text
"expected: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ScriptName -> Text
forall a. IsString a => ScriptName -> a
fromString (ByteString -> ScriptName
forall a. Show a => a -> ScriptName
show ByteString
expected) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\nhash was: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ScriptName -> Text
forall a. IsString a => ScriptName -> a
fromString (ByteString -> ScriptName
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
[MigrationResult a] -> ScriptName -> ScriptName
MigrationResult a -> ScriptName
(Int -> MigrationResult a -> ScriptName -> ScriptName)
-> (MigrationResult a -> ScriptName)
-> ([MigrationResult a] -> ScriptName -> ScriptName)
-> Show (MigrationResult a)
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
$cshowsPrec :: forall a.
Show a =>
Int -> MigrationResult a -> ScriptName -> ScriptName
showsPrec :: Int -> MigrationResult a -> ScriptName -> ScriptName
$cshow :: forall a. Show a => MigrationResult a -> ScriptName
show :: MigrationResult a -> ScriptName
$cshowList :: forall a. Show a => [MigrationResult a] -> ScriptName -> ScriptName
showList :: [MigrationResult a] -> ScriptName -> ScriptName
Show, MigrationResult a -> MigrationResult a -> Bool
(MigrationResult a -> MigrationResult a -> Bool)
-> (MigrationResult a -> MigrationResult a -> Bool)
-> Eq (MigrationResult a)
forall a. Eq a => MigrationResult a -> MigrationResult a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$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
/= :: MigrationResult a -> MigrationResult a -> Bool
Eq, ReadPrec [MigrationResult a]
ReadPrec (MigrationResult a)
Int -> ReadS (MigrationResult a)
ReadS [MigrationResult a]
(Int -> ReadS (MigrationResult a))
-> ReadS [MigrationResult a]
-> ReadPrec (MigrationResult a)
-> ReadPrec [MigrationResult a]
-> Read (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
$creadsPrec :: forall a. Read a => Int -> ReadS (MigrationResult a)
readsPrec :: Int -> ReadS (MigrationResult a)
$creadList :: forall a. Read a => ReadS [MigrationResult a]
readList :: ReadS [MigrationResult a]
$creadPrec :: forall a. Read a => ReadPrec (MigrationResult a)
readPrec :: ReadPrec (MigrationResult a)
$creadListPrec :: forall a. Read a => ReadPrec [MigrationResult a]
readListPrec :: ReadPrec [MigrationResult a]
Read, Eq (MigrationResult a)
Eq (MigrationResult a) =>
(MigrationResult a -> MigrationResult a -> Ordering)
-> (MigrationResult a -> MigrationResult a -> Bool)
-> (MigrationResult a -> MigrationResult a -> Bool)
-> (MigrationResult a -> MigrationResult a -> Bool)
-> (MigrationResult a -> MigrationResult a -> Bool)
-> (MigrationResult a -> MigrationResult a -> MigrationResult a)
-> (MigrationResult a -> MigrationResult a -> MigrationResult a)
-> Ord (MigrationResult a)
MigrationResult a -> MigrationResult a -> Bool
MigrationResult a -> MigrationResult a -> Ordering
MigrationResult a -> MigrationResult a -> MigrationResult a
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
$ccompare :: forall a.
Ord a =>
MigrationResult a -> MigrationResult a -> Ordering
compare :: MigrationResult a -> MigrationResult a -> Ordering
$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
>= :: MigrationResult a -> MigrationResult a -> Bool
$cmax :: forall a.
Ord a =>
MigrationResult a -> MigrationResult a -> MigrationResult a
max :: MigrationResult a -> MigrationResult a -> MigrationResult a
$cmin :: forall a.
Ord a =>
MigrationResult a -> MigrationResult a -> MigrationResult a
min :: MigrationResult a -> MigrationResult a -> MigrationResult a
Ord, (forall a b. (a -> b) -> MigrationResult a -> MigrationResult b)
-> (forall a b. a -> MigrationResult b -> MigrationResult a)
-> Functor MigrationResult
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
$cfmap :: forall a b. (a -> b) -> MigrationResult a -> MigrationResult b
fmap :: forall a b. (a -> b) -> MigrationResult a -> MigrationResult b
$c<$ :: forall a b. a -> MigrationResult b -> MigrationResult a
<$ :: forall a b. a -> MigrationResult b -> MigrationResult a
Functor, (forall m. Monoid m => MigrationResult m -> m)
-> (forall m a. Monoid m => (a -> m) -> MigrationResult a -> m)
-> (forall m a. Monoid m => (a -> m) -> MigrationResult a -> m)
-> (forall a b. (a -> b -> b) -> b -> MigrationResult a -> b)
-> (forall a b. (a -> b -> b) -> b -> MigrationResult a -> b)
-> (forall b a. (b -> a -> b) -> b -> MigrationResult a -> b)
-> (forall b a. (b -> a -> b) -> b -> MigrationResult a -> b)
-> (forall a. (a -> a -> a) -> MigrationResult a -> a)
-> (forall a. (a -> a -> a) -> MigrationResult a -> a)
-> (forall a. MigrationResult a -> [a])
-> (forall a. MigrationResult a -> Bool)
-> (forall a. MigrationResult a -> Int)
-> (forall a. Eq a => a -> MigrationResult a -> Bool)
-> (forall a. Ord a => MigrationResult a -> a)
-> (forall a. Ord a => MigrationResult a -> a)
-> (forall a. Num a => MigrationResult a -> a)
-> (forall a. Num a => MigrationResult a -> a)
-> Foldable MigrationResult
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
$cfold :: forall m. Monoid m => MigrationResult m -> m
fold :: forall m. Monoid m => MigrationResult m -> 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
foldMap' :: forall m a. Monoid m => (a -> m) -> MigrationResult a -> m
$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
foldr' :: forall a b. (a -> b -> 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
foldl' :: forall b a. (b -> a -> b) -> b -> MigrationResult a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> MigrationResult a -> a
foldr1 :: forall a. (a -> a -> a) -> MigrationResult a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> MigrationResult a -> a
foldl1 :: forall a. (a -> a -> a) -> MigrationResult a -> a
$ctoList :: forall a. MigrationResult a -> [a]
toList :: forall a. MigrationResult a -> [a]
$cnull :: forall a. MigrationResult a -> Bool
null :: forall a. MigrationResult a -> Bool
$clength :: forall a. MigrationResult a -> Int
length :: forall a. MigrationResult a -> Int
$celem :: forall a. Eq a => a -> MigrationResult a -> Bool
elem :: forall a. Eq a => a -> MigrationResult a -> Bool
$cmaximum :: forall a. Ord a => MigrationResult a -> a
maximum :: forall a. Ord a => MigrationResult a -> a
$cminimum :: forall a. Ord a => MigrationResult a -> a
minimum :: forall a. Ord a => MigrationResult a -> a
$csum :: forall a. Num a => MigrationResult a -> a
sum :: forall a. Num a => MigrationResult a -> a
$cproduct :: forall a. Num a => MigrationResult a -> a
product :: forall a. Num a => MigrationResult a -> a
Foldable, Functor MigrationResult
Foldable MigrationResult
(Functor MigrationResult, Foldable MigrationResult) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> MigrationResult a -> f (MigrationResult b))
-> (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 (m :: * -> *) a.
    Monad m =>
    MigrationResult (m a) -> m (MigrationResult a))
-> Traversable 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)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> MigrationResult a -> f (MigrationResult b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> MigrationResult a -> f (MigrationResult b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
MigrationResult (f a) -> f (MigrationResult a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
MigrationResult (f a) -> f (MigrationResult a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> MigrationResult a -> m (MigrationResult b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> MigrationResult a -> m (MigrationResult b)
$csequence :: forall (m :: * -> *) a.
Monad m =>
MigrationResult (m a) -> m (MigrationResult a)
sequence :: forall (m :: * -> *) a.
Monad m =>
MigrationResult (m a) -> m (MigrationResult a)
Traversable)

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

-- | Determines how transactions are handled.
-- It 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
(Int -> TransactionControl -> ScriptName -> ScriptName)
-> (TransactionControl -> ScriptName)
-> ([TransactionControl] -> ScriptName -> ScriptName)
-> Show TransactionControl
forall a.
(Int -> a -> ScriptName -> ScriptName)
-> (a -> ScriptName) -> ([a] -> ScriptName -> ScriptName) -> Show a
$cshowsPrec :: Int -> TransactionControl -> ScriptName -> ScriptName
showsPrec :: Int -> TransactionControl -> ScriptName -> ScriptName
$cshow :: TransactionControl -> ScriptName
show :: TransactionControl -> ScriptName
$cshowList :: [TransactionControl] -> ScriptName -> ScriptName
showList :: [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 = (Text -> IO ()) -> (Text -> IO ()) -> Either Text Text -> IO ()
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 Verbosity -> Verbosity -> Bool
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 -> Connection -> IO a -> IO a
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 -> Connection -> IO a -> IO a
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 = Connection -> Query -> IO [SchemaMigration]
forall r. FromRow r => Connection -> Query -> IO [r]
query_ Connection
con Query
q
  where q :: Query
q = [Query] -> Query
forall a. Monoid a => [a] -> a
mconcat
          [ Query
"select filename, checksum, executed_at "
          , Query
"from " Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> ByteString -> Query
Query ByteString
tableName Query -> Query -> Query
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
(Int -> SchemaMigration -> ScriptName -> ScriptName)
-> (SchemaMigration -> ScriptName)
-> ([SchemaMigration] -> ScriptName -> ScriptName)
-> Show SchemaMigration
forall a.
(Int -> a -> ScriptName -> ScriptName)
-> (a -> ScriptName) -> ([a] -> ScriptName -> ScriptName) -> Show a
$cshowsPrec :: Int -> SchemaMigration -> ScriptName -> ScriptName
showsPrec :: Int -> SchemaMigration -> ScriptName -> ScriptName
$cshow :: SchemaMigration -> ScriptName
show :: SchemaMigration -> ScriptName
$cshowList :: [SchemaMigration] -> ScriptName -> ScriptName
showList :: [SchemaMigration] -> ScriptName -> ScriptName
Show, SchemaMigration -> SchemaMigration -> Bool
(SchemaMigration -> SchemaMigration -> Bool)
-> (SchemaMigration -> SchemaMigration -> Bool)
-> Eq SchemaMigration
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SchemaMigration -> SchemaMigration -> Bool
== :: SchemaMigration -> SchemaMigration -> Bool
$c/= :: SchemaMigration -> SchemaMigration -> Bool
/= :: SchemaMigration -> SchemaMigration -> Bool
Eq, ReadPrec [SchemaMigration]
ReadPrec SchemaMigration
Int -> ReadS SchemaMigration
ReadS [SchemaMigration]
(Int -> ReadS SchemaMigration)
-> ReadS [SchemaMigration]
-> ReadPrec SchemaMigration
-> ReadPrec [SchemaMigration]
-> Read SchemaMigration
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS SchemaMigration
readsPrec :: Int -> ReadS SchemaMigration
$creadList :: ReadS [SchemaMigration]
readList :: ReadS [SchemaMigration]
$creadPrec :: ReadPrec SchemaMigration
readPrec :: ReadPrec SchemaMigration
$creadListPrec :: ReadPrec [SchemaMigration]
readListPrec :: ReadPrec [SchemaMigration]
Read)

instance Ord SchemaMigration where
  compare :: SchemaMigration -> SchemaMigration -> Ordering
compare (SchemaMigration ByteString
nameLeft ByteString
_ LocalTime
_) (SchemaMigration ByteString
nameRight ByteString
_ LocalTime
_) =
    ByteString -> ByteString -> Ordering
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 (ByteString -> ByteString -> LocalTime -> SchemaMigration)
-> RowParser ByteString
-> RowParser (ByteString -> LocalTime -> SchemaMigration)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    RowParser ByteString
forall a. FromField a => RowParser a
field RowParser (ByteString -> LocalTime -> SchemaMigration)
-> RowParser ByteString -> RowParser (LocalTime -> SchemaMigration)
forall a b. RowParser (a -> b) -> RowParser a -> RowParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RowParser ByteString
forall a. FromField a => RowParser a
field RowParser (LocalTime -> SchemaMigration)
-> RowParser LocalTime -> RowParser SchemaMigration
forall a b. RowParser (a -> b) -> RowParser a -> RowParser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RowParser LocalTime
forall a. FromField a => RowParser a
field

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