{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Database.PostgreSQL.Simple.Migration
(
defaultOptions
, runMigration
, runMigrations
, sequenceMigrations
, Checksum
, MigrationOptions(..)
, MigrationCommand(..)
, MigrationResult(..)
, ScriptName
, TransactionControl(..)
, Verbosity(..)
, getMigrations
, getMigrations'
, 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)
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]
runMigrations
:: Connection
-> MigrationOptions
-> [MigrationCommand]
-> IO (MigrationResult String)
runMigrations :: Connection
-> MigrationOptions
-> [MigrationCommand]
-> IO (MigrationResult ScriptName)
runMigrations = Bool
-> Connection
-> MigrationOptions
-> [MigrationCommand]
-> IO (MigrationResult ScriptName)
runMigrations' Bool
True
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
runMigrations'
:: Bool
-> Connection
-> MigrationOptions
-> [MigrationCommand]
-> 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]
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
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
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
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(?, ?)"
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
");"
]
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)
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"
]
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
type Checksum = BS.ByteString
type ScriptName = String
data MigrationCommand
= MigrationInitialization
| MigrationDirectory FilePath
| MigrationFile ScriptName FilePath
| MigrationScript ScriptName BS.ByteString
| MigrationValidation MigrationCommand
| MigrationCommands [MigrationCommand]
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)
data CheckScriptResult
= ScriptOk
| ScriptModified (ExpectedVsActual Checksum)
| ScriptNotExecuted
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)
data MigrationResult a
= MigrationError a
| MigrationSuccess
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)
data TransactionControl
= NoNewTransaction
| TransactionPerRun
| TransactionPerStep
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
, MigrationOptions -> ByteString
optTableName :: !BS.ByteString
, MigrationOptions -> Either Text Text -> IO ()
optLogWriter :: !(Either T.Text T.Text -> IO ())
, MigrationOptions -> TransactionControl
optTransactionControl :: !TransactionControl
}
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
getMigrations :: Connection -> IO [SchemaMigration]
getMigrations :: Connection -> IO [SchemaMigration]
getMigrations Connection
con = Connection -> ByteString -> IO [SchemaMigration]
getMigrations' Connection
con ByteString
"schema_migrations"
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"
]
data SchemaMigration = SchemaMigration
{ SchemaMigration -> ByteString
schemaMigrationName :: BS.ByteString
, SchemaMigration -> ByteString
schemaMigrationChecksum :: Checksum
, SchemaMigration -> LocalTime
schemaMigrationExecutedAt :: LocalTime
} 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]