-- |
-- Module      : Database.PostgreSQL.Simple.Migration
-- Copyright   : (c) 2014 Andreas Meingast <ameingast@gmail.com>
--
-- License     : BSD-style
-- Maintainer  : ameingast@gmail.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 String)
runMigration Connection
con MigrationOptions
opts MigrationCommand
cmd = Bool
-> Connection
-> MigrationOptions
-> [MigrationCommand]
-> IO (MigrationResult String)
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 String)
runMigrations = Bool
-> Connection
-> MigrationOptions
-> [MigrationCommand]
-> IO (MigrationResult String)
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 String)
runMigration' Connection
con MigrationOptions
opts MigrationCommand
cmd =
  case MigrationCommand
cmd of
    MigrationCommand
MigrationInitialization ->
      Connection -> MigrationOptions -> IO ()
initializeSchema Connection
con MigrationOptions
opts IO () -> IO (MigrationResult String) -> IO (MigrationResult String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MigrationResult String -> IO (MigrationResult String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure MigrationResult String
forall a. MigrationResult a
MigrationSuccess
    MigrationDirectory String
path ->
      Connection
-> MigrationOptions -> String -> IO (MigrationResult String)
executeDirectoryMigration Connection
con MigrationOptions
opts String
path
    MigrationScript String
name ByteString
contents ->
      Connection
-> MigrationOptions
-> String
-> ByteString
-> IO (MigrationResult String)
executeMigration Connection
con MigrationOptions
opts String
name ByteString
contents
    MigrationFile String
name String
path ->
      Connection
-> MigrationOptions
-> String
-> ByteString
-> IO (MigrationResult String)
executeMigration Connection
con MigrationOptions
opts String
name (ByteString -> IO (MigrationResult String))
-> IO ByteString -> IO (MigrationResult String)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO ByteString
BS.readFile String
path
    MigrationValidation MigrationCommand
validationCmd ->
      Connection
-> MigrationOptions
-> MigrationCommand
-> IO (MigrationResult String)
executeValidation Connection
con MigrationOptions
opts MigrationCommand
validationCmd
    MigrationCommands [MigrationCommand]
commands ->
      Bool
-> Connection
-> MigrationOptions
-> [MigrationCommand]
-> IO (MigrationResult String)
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 String)
runMigrations' Bool
isFirst Connection
con MigrationOptions
opts [MigrationCommand]
commands =
  if Bool
isFirst
    then MigrationOptions
-> Connection
-> IO (MigrationResult String)
-> IO (MigrationResult String)
forall a. MigrationOptions -> Connection -> IO a -> IO a
doRunTransaction MigrationOptions
opts Connection
con IO (MigrationResult String)
go
    else IO (MigrationResult String)
go
  where
    go :: IO (MigrationResult String)
go = [IO (MigrationResult String)] -> IO (MigrationResult String)
forall (m :: * -> *) e.
Monad m =>
[m (MigrationResult e)] -> m (MigrationResult e)
sequenceMigrations [Connection
-> MigrationOptions
-> MigrationCommand
-> IO (MigrationResult String)
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 :: [m (MigrationResult e)] -> m (MigrationResult e)
sequenceMigrations = \case
  [] -> MigrationResult e -> m (MigrationResult e)
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 (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 -> String -> IO (MigrationResult String)
executeDirectoryMigration Connection
con MigrationOptions
opts String
dir =
  String -> IO [String]
scriptsInDirectory String
dir IO [String]
-> ([String] -> IO (MigrationResult String))
-> IO (MigrationResult String)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [String] -> IO (MigrationResult String)
go
  where
    go :: [String] -> IO (MigrationResult String)
go [String]
fs = [IO (MigrationResult String)] -> IO (MigrationResult String)
forall (m :: * -> *) e.
Monad m =>
[m (MigrationResult e)] -> m (MigrationResult e)
sequenceMigrations (String -> IO (MigrationResult String)
executeMigrationFile (String -> IO (MigrationResult String))
-> [String] -> [IO (MigrationResult String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
fs)
    executeMigrationFile :: String -> IO (MigrationResult String)
executeMigrationFile String
f =
      String -> IO ByteString
BS.readFile (String
dir String -> String -> String
</> String
f) IO ByteString
-> (ByteString -> IO (MigrationResult String))
-> IO (MigrationResult String)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Connection
-> MigrationOptions
-> String
-> ByteString
-> IO (MigrationResult String)
executeMigration Connection
con MigrationOptions
opts String
f


-- | Lists all files in the given 'FilePath' 'dir' in alphabetical order.
scriptsInDirectory :: FilePath -> IO [String]
scriptsInDirectory :: String -> IO [String]
scriptsInDirectory String
dir =
  String -> IO [String]
getDirectoryContents String
dir IO [String] -> ([String] -> [String]) -> IO [String]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ([String] -> [String]
forall a. Ord a => [a] -> [a]
sort ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (\String
x -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ String
"." String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
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
-> String
-> ByteString
-> IO (MigrationResult String)
executeMigration Connection
con MigrationOptions
opts String
name ByteString
contents = MigrationOptions
-> Connection
-> IO (MigrationResult String)
-> IO (MigrationResult String)
forall a. MigrationOptions -> Connection -> IO a -> IO a
doStepTransaction MigrationOptions
opts Connection
con (IO (MigrationResult String) -> IO (MigrationResult String))
-> IO (MigrationResult String) -> IO (MigrationResult String)
forall a b. (a -> b) -> a -> b
$ do
  let checksum :: ByteString
checksum = ByteString -> ByteString
md5Hash ByteString
contents
  Connection
-> MigrationOptions -> String -> ByteString -> IO CheckScriptResult
checkScript Connection
con MigrationOptions
opts String
name ByteString
checksum IO CheckScriptResult
-> (CheckScriptResult -> IO (MigrationResult String))
-> IO (MigrationResult String)
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
<> String -> Text
forall a. IsString a => String -> a
fromString String
name
      MigrationResult String -> IO (MigrationResult String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure MigrationResult String
forall a. MigrationResult a
MigrationSuccess
    CheckScriptResult
ScriptNotExecuted -> do
      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)
      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 -> (String, ByteString) -> IO Int64
forall q. ToRow q => Connection -> Query -> q -> IO Int64
execute Connection
con Query
q (String
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
"Execute:\t" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
forall a. IsString a => String -> a
fromString String
name)
      MigrationResult String -> IO (MigrationResult String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure MigrationResult String
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
<> String -> Text
forall a. IsString a => String -> a
fromString String
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 String -> IO (MigrationResult String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> MigrationResult String
forall a. a -> MigrationResult a
MigrationError String
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 String)
executeValidation Connection
con MigrationOptions
opts MigrationCommand
cmd = MigrationOptions
-> Connection
-> IO (MigrationResult String)
-> IO (MigrationResult String)
forall a. MigrationOptions -> Connection -> IO a -> IO a
doStepTransaction MigrationOptions
opts Connection
con (IO (MigrationResult String) -> IO (MigrationResult String))
-> IO (MigrationResult String) -> IO (MigrationResult String)
forall a b. (a -> b) -> a -> b
$
  case MigrationCommand
cmd of
    MigrationCommand
MigrationInitialization ->
      Connection -> String -> IO Bool
existsTable Connection
con (ByteString -> String
BS8.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ MigrationOptions -> ByteString
optTableName MigrationOptions
opts) IO Bool
-> (Bool -> IO (MigrationResult String))
-> IO (MigrationResult String)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
r -> MigrationResult String -> IO (MigrationResult String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MigrationResult String -> IO (MigrationResult String))
-> MigrationResult String -> IO (MigrationResult String)
forall a b. (a -> b) -> a -> b
$ if Bool
r
        then MigrationResult String
forall a. MigrationResult a
MigrationSuccess
        else String -> MigrationResult String
forall a. a -> MigrationResult a
MigrationError (String
"No such table: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
BS8.unpack (MigrationOptions -> ByteString
optTableName MigrationOptions
opts))
    MigrationDirectory String
path ->
      String -> IO [String]
scriptsInDirectory String
path IO [String]
-> ([String] -> IO (MigrationResult String))
-> IO (MigrationResult String)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> [String] -> IO (MigrationResult String)
goScripts String
path
    MigrationScript String
name ByteString
contents ->
      String -> ByteString -> IO (MigrationResult String)
validate String
name ByteString
contents
    MigrationFile String
name String
path ->
      String -> ByteString -> IO (MigrationResult String)
validate String
name (ByteString -> IO (MigrationResult String))
-> IO ByteString -> IO (MigrationResult String)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO ByteString
BS.readFile String
path
    MigrationValidation MigrationCommand
_ ->
      MigrationResult String -> IO (MigrationResult String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure MigrationResult String
forall a. MigrationResult a
MigrationSuccess
    MigrationCommands [MigrationCommand]
cs ->
      [IO (MigrationResult String)] -> IO (MigrationResult String)
forall (m :: * -> *) e.
Monad m =>
[m (MigrationResult e)] -> m (MigrationResult e)
sequenceMigrations (Connection
-> MigrationOptions
-> MigrationCommand
-> IO (MigrationResult String)
executeValidation Connection
con MigrationOptions
opts (MigrationCommand -> IO (MigrationResult String))
-> [MigrationCommand] -> [IO (MigrationResult String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MigrationCommand]
cs)
  where
    validate :: String -> ByteString -> IO (MigrationResult String)
validate String
name ByteString
contents =
      Connection
-> MigrationOptions -> String -> ByteString -> IO CheckScriptResult
checkScript Connection
con MigrationOptions
opts String
name (ByteString -> ByteString
md5Hash ByteString
contents) IO CheckScriptResult
-> (CheckScriptResult -> IO (MigrationResult String))
-> IO (MigrationResult String)
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
<> String -> Text
forall a. IsString a => String -> a
fromString String
name)
          MigrationResult String -> IO (MigrationResult String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure MigrationResult String
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
<> String -> Text
forall a. IsString a => String -> a
fromString String
name)
          MigrationResult String -> IO (MigrationResult String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> MigrationResult String
forall a. a -> MigrationResult a
MigrationError (String -> MigrationResult String)
-> String -> MigrationResult String
forall a b. (a -> b) -> a -> b
$ String
"Missing: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
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
<> String -> Text
forall a. IsString a => String -> a
fromString String
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 String -> IO (MigrationResult String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> MigrationResult String
forall a. a -> MigrationResult a
MigrationError (String -> MigrationResult String)
-> String -> MigrationResult String
forall a b. (a -> b) -> a -> b
$ String
"Checksum mismatch: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
name)

    goScripts :: String -> [String] -> IO (MigrationResult String)
goScripts String
path [String]
xs = [IO (MigrationResult String)] -> IO (MigrationResult String)
forall (m :: * -> *) e.
Monad m =>
[m (MigrationResult e)] -> m (MigrationResult e)
sequenceMigrations (String -> String -> IO (MigrationResult String)
goScript String
path (String -> IO (MigrationResult String))
-> [String] -> [IO (MigrationResult String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
xs)
    goScript :: String -> String -> IO (MigrationResult String)
goScript String
path String
x = String -> ByteString -> IO (MigrationResult String)
validate String
x (ByteString -> IO (MigrationResult String))
-> IO ByteString -> IO (MigrationResult String)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO ByteString
BS.readFile (String
path String -> String -> String
</> String
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 -> String -> ByteString -> IO CheckScriptResult
checkScript Connection
con MigrationOptions
opts String
name ByteString
fileChecksum =
  Connection -> Query -> Only String -> IO [Only ByteString]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
query Connection
con Query
q (String -> Only String
forall a. a -> Only a
Only String
name) IO [Only ByteString]
-> ([Only ByteString] -> IO CheckScriptResult)
-> IO CheckScriptResult
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    [] ->
      CheckScriptResult -> IO CheckScriptResult
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 (f :: * -> *) a. Applicative f => a -> f a
pure CheckScriptResult
ScriptOk
    Only ByteString
dbChecksum:[Only ByteString]
_ ->
      CheckScriptResult -> IO CheckScriptResult
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 :: forall a. a -> a -> ExpectedVsActual a
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 -> String -> String
[MigrationCommand] -> String -> String
MigrationCommand -> String
(Int -> MigrationCommand -> String -> String)
-> (MigrationCommand -> String)
-> ([MigrationCommand] -> String -> String)
-> Show MigrationCommand
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [MigrationCommand] -> String -> String
$cshowList :: [MigrationCommand] -> String -> String
show :: MigrationCommand -> String
$cshow :: MigrationCommand -> String
showsPrec :: Int -> MigrationCommand -> String -> String
$cshowsPrec :: Int -> MigrationCommand -> String -> String
Show, MigrationCommand -> MigrationCommand -> Bool
(MigrationCommand -> MigrationCommand -> Bool)
-> (MigrationCommand -> MigrationCommand -> Bool)
-> Eq MigrationCommand
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]
(Int -> ReadS MigrationCommand)
-> ReadS [MigrationCommand]
-> ReadPrec MigrationCommand
-> ReadPrec [MigrationCommand]
-> Read 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
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
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
$cp1Ord :: Eq 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
  { ExpectedVsActual a -> a
evaExpected :: !a
  , ExpectedVsActual a -> a
evaActual :: !a
  } deriving (Int -> ExpectedVsActual a -> String -> String
[ExpectedVsActual a] -> String -> String
ExpectedVsActual a -> String
(Int -> ExpectedVsActual a -> String -> String)
-> (ExpectedVsActual a -> String)
-> ([ExpectedVsActual a] -> String -> String)
-> Show (ExpectedVsActual a)
forall a. Show a => Int -> ExpectedVsActual a -> String -> String
forall a. Show a => [ExpectedVsActual a] -> String -> String
forall a. Show a => ExpectedVsActual a -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [ExpectedVsActual a] -> String -> String
$cshowList :: forall a. Show a => [ExpectedVsActual a] -> String -> String
show :: ExpectedVsActual a -> String
$cshow :: forall a. Show a => ExpectedVsActual a -> String
showsPrec :: Int -> ExpectedVsActual a -> String -> String
$cshowsPrec :: forall a. Show a => Int -> ExpectedVsActual a -> String -> String
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 -> String -> String
[CheckScriptResult] -> String -> String
CheckScriptResult -> String
(Int -> CheckScriptResult -> String -> String)
-> (CheckScriptResult -> String)
-> ([CheckScriptResult] -> String -> String)
-> Show CheckScriptResult
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [CheckScriptResult] -> String -> String
$cshowList :: [CheckScriptResult] -> String -> String
show :: CheckScriptResult -> String
$cshow :: CheckScriptResult -> String
showsPrec :: Int -> CheckScriptResult -> String -> String
$cshowsPrec :: Int -> CheckScriptResult -> String -> String
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
<> String -> Text
forall a. IsString a => String -> a
fromString (ByteString -> String
forall a. Show a => a -> String
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
<> String -> Text
forall a. IsString a => String -> a
fromString (ByteString -> String
forall a. Show a => a -> String
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 -> String -> String
[MigrationResult a] -> String -> String
MigrationResult a -> String
(Int -> MigrationResult a -> String -> String)
-> (MigrationResult a -> String)
-> ([MigrationResult a] -> String -> String)
-> Show (MigrationResult a)
forall a. Show a => Int -> MigrationResult a -> String -> String
forall a. Show a => [MigrationResult a] -> String -> String
forall a. Show a => MigrationResult a -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [MigrationResult a] -> String -> String
$cshowList :: forall a. Show a => [MigrationResult a] -> String -> String
show :: MigrationResult a -> String
$cshow :: forall a. Show a => MigrationResult a -> String
showsPrec :: Int -> MigrationResult a -> String -> String
$cshowsPrec :: forall a. Show a => Int -> MigrationResult a -> String -> String
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
/= :: 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)
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
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, 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
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
$cp1Ord :: forall a. Ord a => Eq (MigrationResult a)
Ord, a -> MigrationResult b -> MigrationResult a
(a -> b) -> MigrationResult a -> MigrationResult b
(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
<$ :: a -> MigrationResult b -> MigrationResult a
$c<$ :: forall a b. a -> MigrationResult b -> MigrationResult a
fmap :: (a -> b) -> MigrationResult a -> MigrationResult b
$cfmap :: forall a b. (a -> b) -> MigrationResult a -> MigrationResult b
Functor, MigrationResult a -> Bool
(a -> m) -> MigrationResult a -> m
(a -> b -> b) -> b -> MigrationResult a -> b
(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
product :: MigrationResult a -> a
$cproduct :: forall a. Num a => MigrationResult a -> a
sum :: MigrationResult a -> a
$csum :: forall a. Num a => MigrationResult a -> a
minimum :: MigrationResult a -> a
$cminimum :: forall a. Ord a => MigrationResult a -> a
maximum :: MigrationResult a -> a
$cmaximum :: forall a. Ord a => MigrationResult a -> a
elem :: a -> MigrationResult a -> Bool
$celem :: forall a. Eq a => a -> MigrationResult a -> Bool
length :: MigrationResult a -> Int
$clength :: forall a. MigrationResult a -> Int
null :: MigrationResult a -> Bool
$cnull :: forall a. MigrationResult a -> Bool
toList :: MigrationResult a -> [a]
$ctoList :: forall a. MigrationResult a -> [a]
foldl1 :: (a -> a -> a) -> MigrationResult a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> MigrationResult a -> a
foldr1 :: (a -> a -> a) -> MigrationResult a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> MigrationResult a -> a
foldl' :: (b -> a -> b) -> b -> MigrationResult a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> MigrationResult a -> b
foldl :: (b -> a -> b) -> b -> MigrationResult a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> MigrationResult a -> b
foldr' :: (a -> b -> b) -> b -> MigrationResult a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> MigrationResult a -> b
foldr :: (a -> b -> b) -> b -> MigrationResult a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> MigrationResult a -> b
foldMap' :: (a -> m) -> MigrationResult a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> MigrationResult a -> m
foldMap :: (a -> m) -> MigrationResult a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> MigrationResult a -> m
fold :: MigrationResult m -> m
$cfold :: forall m. Monoid m => MigrationResult m -> m
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
(a -> f b) -> MigrationResult a -> f (MigrationResult b)
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 :: MigrationResult (m a) -> m (MigrationResult a)
$csequence :: forall (m :: * -> *) a.
Monad m =>
MigrationResult (m a) -> m (MigrationResult a)
mapM :: (a -> m b) -> MigrationResult a -> m (MigrationResult b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> MigrationResult a -> m (MigrationResult b)
sequenceA :: MigrationResult (f a) -> f (MigrationResult a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
MigrationResult (f a) -> f (MigrationResult a)
traverse :: (a -> f b) -> MigrationResult a -> f (MigrationResult b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> MigrationResult a -> f (MigrationResult b)
$cp2Traversable :: Foldable MigrationResult
$cp1Traversable :: Functor MigrationResult
Traversable)

data Verbosity
  = Verbose
  | Quiet
  deriving (Int -> Verbosity -> String -> String
[Verbosity] -> String -> String
Verbosity -> String
(Int -> Verbosity -> String -> String)
-> (Verbosity -> String)
-> ([Verbosity] -> String -> String)
-> Show Verbosity
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Verbosity] -> String -> String
$cshowList :: [Verbosity] -> String -> String
show :: Verbosity -> String
$cshow :: Verbosity -> String
showsPrec :: Int -> Verbosity -> String -> String
$cshowsPrec :: Int -> Verbosity -> String -> String
Show, Verbosity -> Verbosity -> Bool
(Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool) -> Eq Verbosity
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 -> String -> String
[TransactionControl] -> String -> String
TransactionControl -> String
(Int -> TransactionControl -> String -> String)
-> (TransactionControl -> String)
-> ([TransactionControl] -> String -> String)
-> Show TransactionControl
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [TransactionControl] -> String -> String
$cshowList :: [TransactionControl] -> String -> String
show :: TransactionControl -> String
$cshow :: TransactionControl -> String
showsPrec :: Int -> TransactionControl -> String -> String
$cshowsPrec :: Int -> TransactionControl -> String -> String
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 :: Verbosity
-> ByteString
-> (Either Text Text -> IO ())
-> TransactionControl
-> MigrationOptions
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 :: 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 :: 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 -> String -> String
[SchemaMigration] -> String -> String
SchemaMigration -> String
(Int -> SchemaMigration -> String -> String)
-> (SchemaMigration -> String)
-> ([SchemaMigration] -> String -> String)
-> Show SchemaMigration
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [SchemaMigration] -> String -> String
$cshowList :: [SchemaMigration] -> String -> String
show :: SchemaMigration -> String
$cshow :: SchemaMigration -> String
showsPrec :: Int -> SchemaMigration -> String -> String
$cshowsPrec :: Int -> SchemaMigration -> String -> String
Show, SchemaMigration -> SchemaMigration -> Bool
(SchemaMigration -> SchemaMigration -> Bool)
-> (SchemaMigration -> SchemaMigration -> Bool)
-> Eq SchemaMigration
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]
(Int -> ReadS SchemaMigration)
-> ReadS [SchemaMigration]
-> ReadPrec SchemaMigration
-> ReadPrec [SchemaMigration]
-> Read 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
_) =
    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 (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 (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]